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Summary  W\j  j 
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This  report  provides  an  overview  of  the  pFX/DLX  compiler.  The  source  language 
for  the  compiler  is  pFX,  a  Lisp  dialect  that  is  a  subset  of  FX-91.  /iFX  is  stati¬ 
cally  typed,  and  employs  a  type  reconstruction  algorithm  to  eliminate  the  need  for 
type  declarations.  The  compile*  produces  assembly  code  for  the  DLX,  a  simplified 
RISC  architecture  introduced  by  Patterson  and  Hennessy  in  their  text,  Computer 
Architecture:  A  Quantitative  Approach. 

pFX/DLX  was  written  for  the  primary  purpose  of  conducting  experiments  concerning 
basic  features  of  programming  language  implementation.  For  example,  it  is  used  in 
the  MIT  graduate- level  programming  language  course,  where  students  are  expected 
to  read,  understand,  and  modify  the  compiler,  in  order  to  investigate  the  effects  of 
various  optimizations. 

The  organization  of  the  compiler  and  its  intermediate  forms  are  described  via  ex¬ 
amples.  The  register  usage,  memory  layouts,  and  calling  conventions  are  explained. 
Some  suggested  experiments  are  presented,  and  the  annotated  implementation  of 
pFX/DLX  is  provided.  The  report  is  not  entirely  self-contained,  as  it  does  not  com¬ 
pletely  describe  the  details  of  the  source  and  target  languages. 
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Preface 

This  report  represents  a  combination  of  several  sources  of  documentation  con¬ 
cerning  the  pedagogical  compilers  which  have  been  written  for  MIT  EECS 
course  6.821.  The  first  such  compiler  was  written  by  Jonathan  Rees.  That 
compiler  was  used  for  several  years  between  approximately  1987  and  1990.  It 
was  modified  in  miner  ways  by  Franklyn  Turbak,  Mark  Sheldon,  and  James 
O’Toole.  Students  made  use  of  the  compiler  in  the  final  problem  sets  of  course 
6.821. 

During  early  1991,  Doug  Grundman  rewrote  most  of  the  compiler.  Doug  de¬ 
signed  the  intermediate  code  representations  and  wrote  a  new  backend  for  the 
compiler  which  produced  assembly  code  compatible  with  the  DLX  architecture 
[2].  During  the  summer  of  1991,  Raymie  Stata  joined  the  compiler  project. 
Raymie  and  Doug  rewrote  portions  of  the  compiler  to  improve  performance, 
implemented  tail-recursive  call  optimization,  and  corrected  the  generation  of 
code  which  used  the  stack.  Raymie  also  added  support  for  more  of  the  source 
language  (pFX),  and  modified  the  garbage  collector  to  avoid  copying  stack- 
allocated  data. 

At  the  time  of  this  writing,  the  compiler  and  associated  simulation  software 
are  being  prepared  for  student  use  in  the  Fall  1992  semester  of  6.821.  Brian 
Reistad  is  improving  the  typechecking  phase  of  the  compiler.  This  document 
was  compiled  from  three  primary  sources:  Doug’s  general  overview  of  the 
compiler  phases,  Raymie ’s  description  of  register  usage  conventions,  and  older 
materials  describing  Rees’s  version  of  the  compiler.  These  documents  were 
merged;  some  additional  text  and  figures  were  added. 

All  of  the  software  and  documentation  described  in  this  report  is  available  in 
electronic  form.  We  hope  that  this  report  will  permit  the  reader  to  enjoy  the 
6.821  pedagogical  compiler. 

James  O’Toole 
Editor 
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1  INTRODUCTION 


1  Introduction 

The  MIT  subject  6.821  is  an  introduction  to  programming  language  semantics  and 
pragmatics  for  graduate  students.  In  the  laboratory  portion  of  6.821,  students  read 
and  modify  a  simple  compiler  to  gain  hands-on  experience  with  fundamental  concepts 
in  compilation. 

We  have  built  a  new  compiler  for  the  /iFX  programming  language  for  use  in  the 
class.  The  compiler,  which  generates  code  for  Patterson  and  Hennessy’s  DLX  archi¬ 
tecture,  was  designed  to  be  especially  easy  to  understand  and  modify.  The  purpose  of 
this  report  is  to  make  the  compiler  more  accessible  by  explaining  its  organization  and 
providing  an  overview  of  various  internal  representations.  Information  for  acquiring 
a  copy  of  the  /iFX  software  package  and  a  simulator  for  DLX  is  in  Section  5.  Any 
questions  or  bug  reports  concerning  the  software  described  in  this  report  should  be 
sent  via  electronic  mail  to  microf  xfibrokaw.  lcs  .mit .  edu. 

The  /iFX/DLX  compiler  was  designed  with  two  goals  in  mind.  First,  there  was  the 
pedagogic  goal:  the  compiler  needed  to  be  useful  for  teaching  compilation  techniques 
to  students.  The  second  goal  was  that  the  compiler  had  to  afford  easy  experimentation 
by  being  easy  to  modify.  That  way,  the  compiler  would  be  useful  not  only  in  the 
classroom,  but  in  a  research  setting  as  well. 

These  two  goals  —  readability  and  writability  —  overshadowed  all  others  in  the 
design  of  the  compiler.  /iFX/DLX  makes  no  pretense  of  being  a  production  compiler. 
Code  quality  and  space  efficiency  have  been  largely  ignored  in  favor  of  intelligibility. 
For  example,  the  compiler’s  code  generator  contains  only  a  few  special  case  code 
improvements,  and  these  were  added  only  to  improve  the  readability  of  the  emitted 
code. 

These  two  primary  goals  determine  that  the  compiler  be  as  simple  as  possible, 
and  as  modular  as  possible.  The  former  aspect  says  that  the  compiler  contains  no 
hidden  intricacies  to  improve  run-time  performance  or  compilation  speed,  while  the 
latter  decomposes  the  compiler  into  several  simple  passes  that  interact  only  through 
well-defined  and  well-documented  interfaces. 

It  follows  that  adding  a  new  pass  (such  as  an  optimizer)  is  relatively  easy,  as  is 
making  modifications  to  any  of  the  pre-existing  passes.  Experience  has  indeed  shown 
this  to  be  the  case. 

The  remaining  sections  of  this  report  discuss  the  features  of  the  /iFX  language, 
introduce  the  reader  to  the  DLX  target  machine,  give  an  overview  of  the  compiler, 
and  tell  where  to  obtain  a  copy  of  the  software. 

1.1  The  ^zFX  Language 

/iFX  is  a  subset  of  the  FX-91  programming  language  [1],  and  may  be  thought  of  as  a 
cross  between  Scheme  and  ML.  The  /iFX  syntax  is  shown  below. 

/iFX  is  lexically  scoped,  with  all  parameters  passed  by  value.  Like  FX-91,  /iFX 
is  strongly  typed,  incorporating  an  ML-style  type  reconstructor.  The  language  has 
first-class  procedures,  tail-recursion,  and  garbage  collection.  Its  primitive  data  types 
include  integers,  characters,  symbols ,  strings,  references ,  and  procedures. 
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1  INTRODUCTION 


I  €  Identifier 
E  €  Expression 
N  €  Integer-Numeral 
B  €  Boolean-literal  =  {#t,  #f} 

S  €  String-literal  =  character  sequences  delimited  by  double-quotes 
L  €  Literal  =  Integer-Numeral  U  Boolean-literal  U  String-literal 


E  ::=  L 
|  I 

j  (lambda  (I*)  Eb ) 

|  CEo  E*) 

|  (let  ((I  E)*)  Eb) 

|  (letrec  ((I  E)*)  Eb) 
j  (ref  E) 

|  (“  E) 

|  (:=  Eh  Eh) 

|  (if  Eh  Eh  Eh) 

|  (and  E*) 

|  (or  E*) 
j  (begin  E*) 


The  language  supported  by  the  compiler  uses  the  S-expression  style  in  order  to 
simplify  parsing  and  permit  easy  experimentation  with  new  language  features.  A 
number  of  primitive  procedures  are  supported  by  the  compiler  as  part  of  the  runtime 
library  (see  Appendix  B). 


1.2  The  Target  Machine 

The  DLX  architecture  was  introduced  by  Patterson  and  Hennessy  in  their  book, 
Computer  Architecture:  A  Quantitative  Approach  [2].  DLX  has  a  generic  RISC 
instruction  set  very  similar  to  that  of  the  MIPS  architecture.  It  has  32  32-bit  general- 
purpose  registers,  32  32-bit  floating-point  registers,  and  no  condition  codes.  There  is 
one  data  addressing  mode:  register  indirect  with  (signed)  16-bit  offset.  All  memory 
accesses  must  be  aligned  according  to  the  size  of  the  referenced  datum,  otherwise 
a  trap  occurs.  DLX  has  a  delay  slot  following  each  branch  or  trap  instruction,  but 
differs  from  the  MIPS  architecture  in  that  it  has  load  interlocks. 

There  is  a  publicly  available  simulator  for  DLX,  called  dlxsim.  The  /iFX/DLX 
compiler  emits  code  which  runs  directly  on  dlxsim,  but  also  contains  a  built-in  DLX 
emulator  that  suffices  for  running  small  test  cases.  The  simulator  for  DLX  may  be  ob¬ 
tained  via  anonymous  ftp  from  max .  Stanford .  edu  in  pub/hennessy-patter  son .  software. 
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2  COMPILER  STRUCTURE 


2  Compiler  structure 

H FX/DLX  is  organized  into  seven  passes  that  make  use  of  three  intermediate  forms: 
exp,  icode,  and  ocode.  For  modularity,  the  compiler  passes  communicate  only  through 
these  intermediate  forms,  which  have  been  designed  to  be  easy  to  understand  and  to 
work  with  so  that  students  need  not  deal  with  unnecessary  obstacles. 

The  seven  compiler  passes  are: 

parser:  converts  s-expressions  to  exps. 

type  reconstructor:  annotates  exp  nodes  with  type  information. 

translator:  converts  exps  to  icode. 

optimizer:  icode  to  (improved)  icode. 

code  generator:  converts  icode  to  ocode. 

peephole  optimizer:  ocode  to  (improved)  ocode. 

output  stage:  ocode  to  assembly-code  text. 

The  parser,  type  reconstructor,  translator,  and  code  generator  have  been  mentioned 
above.  The  local  optimizer  currently  only  implements  tail  calls.  Although  a  peephole 
optimizer  is  not  currently  implemented,  the  compiler  provides  for  one  so  that  delay 
slot  filling  can  be  done.  The  final  output  stage  takes  care  of  formatting  the  instruc¬ 
tions  into  an  ASCII  text  representation  so  that  dlxsim  will  accept  the  output  file.  It 
also  supplements  the  compiled  program  with  a  pre-written  run-time  support  system 
(see  Appendix  D),  thus  functioning  as  a  simple  linker. 

The  software  comes  with  a  built-in  interpreter  which  can  execute  programs  at  the 
ocode  level.  This  interpreter,  though  slow,  provides  an  easy  way  to  test  new  compiler 
features.  It  is  outfitted  with  a  run-time  environment  similar  to  that  supplied  for 
running  under  dlxsim.  Figure  2  shows  the  organization  of  the  various  stages  of  the 
compiler  and  its  associated  ocode  simulator. 


2.1  Using  the  System 

The  system  is  written  in  mini-FX,  which  is  a  slightly  larger  subset  of  FX-91  than  is 
pFX.  Several  commands  have  been  implemented  that  allow  the  user  to  display  the 
output  of  any  stage  of  the  compiler.  All  of  these  procedures  take  a  single  argument 
which  is  a  /* FX  expression  represented  as  an  S-expression.  This  set  of  commands 
includes: 

•  (test-parse  sexpr):  prints  a  freshly-parsed  representation  of  the  p.FX  ex¬ 
pression  sexpr. 

•  (check  sexpr):  type-checks  sexpr. 

•  (show- type-check  sexpr):  type-checks  sexpr  and  displays  the  parse  tree  an¬ 
notated  with  the  reconstructed  type  information. 

•  (itest-compile  sexpr):  compiles  sexpr  and  prints  (unoptimized)  icode. 

•  (otest-compile  sexpr):  compiles  sexpr  and  prints  optimized  icode. 
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2.1  Using 


Figure  2:  Organization  of  /iFX/DLX 


the  System 


Emulator 
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2  COMPILER  STRUCTURE 


•  (test-compile  sexpr):  compiles  sexpr  and  prints  DLX  assembly  code.  This 
is  essentially  ocode,  printed  in  a  more  readable  format. 

•  (fx  sexpr):  compiles  sexpr,  emitting  a  runnable  DLX  program  in  the  file  fx.s 
in  the  current  directory.  This  file  is  the  output  of  test-compile  with  run-time 
support  code  added.  It  is  suitable  for  loading  directly  into  dlxsim. 

•  (run  sexpr):  compiles  and  interprets  sexpr,  using  the  built-in  ocode  inter¬ 
preter. 

2.2  The  “exp”  Intermediate  Form 

The  highest-level  intermediate  form  —  the  “exp”  form  —  is  a  parsed  representation 
of  the  source  language.  It  encodes  primitives  (booleans,  characters,  integers,  strings, 
symbols  and  variables),  abstractions,  applications,  conditionals,  let,  and  letrec. 
The  parser  desugaxs  all  other  language  features  into  these  forms. 

>  (test-paxse  '(lambda  (x)  x)) 

(ABSTRACTION->EXP  TY  (X)  (VARIABLE->EXP  TY  X)) 


In  the  above  example,  the  micro-FX  program  is  quoted  to  make  it  a  scheme  s- 
expression.  The  parse  tree  which  is  returned  indicates  that  this  s-expression  rep¬ 
resents  an  abstraction.  Inside  the  parse  tree,  TY  stands  for  type  information  which 
will  be  filled  in  by  the  type-reconstructor. 

Each  exp  tree  node  contains  a  field  to  hold  the  type  of  an  expression.  The  type  of 
each  primitive  constant  is  filled  in  at  parse  time;  all  others  are  filled  in  later  by  the 
type  reconstructor. 

>  (teat-parse  '((lambda  (x)  x)  19)) 

(COMBINATIQN->EXP  TY  (ABSTRACTION->EXP  TY  (X)  (VARIABLE->EXP  TY  X)) 

( (INT->EXP  TY  19))) 


In  the  above  example,  the  closure  is  created  and  called  with  a  list  of  arguments  (19). 
The  type  reconstructor  implements  generic  polymorphism  [1], 


>  (check  '(lambda  (x)  x)) 
(->  (?X-1)  ?X-1) 


In  this  example,  the  type  computed  by  the  reconstruction  phase  is  a  function  taking 
an  argument  of  type  ?X-1  and  returning  a  value  of  type  ?X-1.  The  notation  ’X-l 
represents  an  unbound  type  variable,  and  indicates  that  the  type-checking  problem 
is  under-constrained.  In  other  words,  this  function  is  polymorphic  in  the  type  of  its 
one  argument. 

The  show-type-check  procedure  shows  the  parse  tree  for  an  expression  with  full 
type  information: 
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2.3  The  icode ”  Intermediate  Form 


>  (shov-type-check  ’((lambda  (x)  x)  19)) 

(COMBINATION->EXP  INT  (ABSTRACTION->EXP  INT  (X)  (VARIABLE->EXP  INT  X)) 

( (INT->EXP  INT  19))) 


In  this  example,  the  type  of  the  argument  and  result  of  the  lambda  expression  have 
been  determined  to  be  the  same  as  the  type  of  the  integer  constant  19. 

2.3  The  “icode”  Intermediate  Form 

The  middle- most  intermediate  form  is  termed  “icode”.  Icode  is  designed  to  represent 
programs  at  the  lowest  possible  level  of  abstraction  without  explicit  register  refer¬ 
ences.  Type  information  present  in  the  parse  tree  is  also  stored  in  the  icode,  although 
it  is  not  normally  printed  when  icode  is  displayed.  The  absence  of  explicit  register 
references  allows  the  issues  of  instruction  selection  and  register  allocation  to  be  de¬ 
ferred  to  a  subsequent  pass.  This  goal  was  achieved  with  one  exception:  icode  knows 
of  the  existence  of  an  environment  register  so  that  the  creation  of  closures  can  be 
represented. 


>  (itest-compile  ’ (+  1  2)) 
Type :  int 
Icode : 


START. 1: 

(return  (+  1  2)) 


Here,  START _1  is  a  label,  and  the  “return”  line  is  a  tree  printed  (roughly)  in  preorder. 
STARTJ.  always  appears,  and  it  is  whei  the  execution  of  the  compiled  program 
begins. 

>  (itest-compile  '((lambda  (x)  (+  x  x))  7)) 

Type:  int 
Icode : 

START. 1: 

(return  (call  (alloc  2  ("LAMBDA.2"  (r  2)))  7)) 
LAMBDA.2 : 

(body  (1)  (return  (+  (var  0  1)  (var  0  l ));; 

In  this  example,  the  lambda  body  has  been  separated  from  the  call,  (alloc  2  (...)) 

al’ocates  2  locations,  initializing  them  with  the  values  shown  as  arguments  (the  lo¬ 
cation  LAMBDA.2  and  register  2  (the  previously-mentioned  environment  register)). 
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2  COMPILER  STRUCT URE 


The  instance  of  CALL  shown  here  takes  two  “parameters” :  the  first  is  the  function 
(closure),  and  the  second  is  the  function’s  parameter.  Finally,  (body  (1)  .  .  .)  ac¬ 
cepts  one  parameter,  an  expression,  and  runs  it  within  a  (newly-constructed)  environ¬ 
ment  accepting  1  parameter.  The  icode  form  (var  0  1)  is  a  reference  to  the  variable 
x.  For  further  explanation  of  environments  and  variable  access,  see  section  3.2.1. 


>  (otest-compile  ’((lambda  (x)  (+  x  x))  7)) 

Type :  int 

Icode : 

START. 1: 

(jump  (alloc  2  ("LAMBDA.2"  (r  2)))  7) 
LAMBDA. 2 : 

(body  (1)  (return  (+  (vax  0  1)  (var  0  1)))) 


In  this  example,  the  call — return  sequence  has  been  replaced  with  a  jump,  thus 
implementing  a  tail-call.  (JUMP  has  the  same  syntax  as  CALL.) 


Any  program  expressed  in  icode  takes  the  form  of  a  list  of  labelled  trees.  The 
job  of  the  compiler  pass  converting  exps  to  icode  is  primarily  to  separate  lambda 
bodies  from  the  creation  of  corresponding  closures.  This  explains  why  icode  takes  the 
form  of  a  list  of  trees  rather  than  a  single  tree:  any  expression  containing  a  lambda 
sub-expression  is  split  into  two  trees.  One  of  these  trees  describes  the  creation  of  the 
closure,  while  the  other  describes  the  function’s  code. 


2.4  The  “ocode”  Intermediate  Form 

The  lowest-level  intermediate  form  is  termed  “ocode”.  It  has  a  1-1  correspondence 
with  DLX  assembly  code,  and  is  converted  to  textual  assembly  code  by  the  compiler’s 
final  pass.  The  code  generator  could  have  been  designed  to  emit  assembly-code  di¬ 
rectly,  but  the  use  of  an  intermediate  form  like  ocode  facilitates  the  construction  of 
peep-hole  optimizers,  delay-slot  fillers  and  the  like. 
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>  (test-compile  ' (+  1  2)) 


Type :  int 

Object  code: 

Code : 

START. 1: 

addi  ARGO,  ZERO,  2 

addi  ARGO,  ARGO,  4 

or  VAL,  ARGO,  ZERO 

lw  ATEMP,  11 (FP) 

jr  ATEMP 

nop 


This  example  shows  the  tiny  program  from  above,  fully  compiled.  The  “1”  and  “2” 
show  up  as  “2”  and  “4”  in  the  object  code  because  they  are  tagged  values  (see  section 
3.1.1).  There  is  an  assumption  here  that  this  code  has  been  called  with  the  standard 
calling  convention.  Both  tagging  and  calling  conventions  will  be  explained  more  fully 
in  section  3.2. 

3  The  Runtime  Environment 

The  compiler  comes  with  its  own  runtime  library.  Included  in  the  library  are  a  memory 
allocator  (including  a  simple  stop-and-copy  garbage-collector),  routines  for  saving  and 
restoring  registers  to  and  from  frames,  and  miscellaneous  built-in  primitives  and  I/O 
functions.  The  runtime  library  handles  program  invocation  and  termination,  and 
prints  the  result  of  each  computation  and  memory  usage  statistics  after  each  run. 

3.1  Memory  organization 

All  heap  and  stack  memory  is  organized  into  blocks.  Each  block  is  a  sequence  of 
four-byte  slots  whose  address  is  a  multiple  of  four.  The  main  reason  for  this  is  that 
in  DLX,  as  in  most  other  modern  RISC  processors,  all  memory  references  to  pointers 
or  integers  work  only  at  four-byte  boundaries.  One  particular  slot  in  each  block 
is  called  the  “size”  slot  and  the  remaining  slots  are  called  the  “data  slots.”  The 
“size”  slot  is  only  accessible  by  the  run-time  system  (which  includes  the  memory 
allocator),  while  the  data  slots  are  accessible  to  the  user’s  program.  This  use  of 
explicit  size  information,  though  somewhat  wasteful  of  memory,  makes  the  system’s 
garbage  collector  easier  to  read  and  understand. 

The  slots  of  a  block  axe  numbered  starting  from  —1.  Slot  —1  is  the  size  slot.  Slot 
0  is  the  first  data  slot;  slot  1  is  the  second  data  slot;  etc.  Objects  start  at  the  lower 
address:  the  address  of  slot  i  +  1  is  always  four  bytes  past  the  address  of  slot  i. 

The  system  supports  two  memory  allocation  primitives:  -SALLOC,  which  allocates 
and  zeroes  a  memory  block  from  the  stack,  and  -ALLOC,  which  allocates  and  zeroes  a 
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memory  block  from  the  heap.  If  the  stack  memory  allocator  discovers  that  there  is 
insufficient  stack  memory  available  with  which  to  satisfy  the  current  _S ALLOC  request, 
execution  halts  with  an  error.  On  the  other  hand,  if  the  heap  memory  allocator 
discovers  that  there  is  insufficient  heap  memory  available  with  which  to  satisfy  the 
current  _ALL0C  request,  it  calls  the  run-time  system’s  garbage  collector  in  an  attempt 
to  discover  memory  that  may  be  reused.  If  this  attempt  is  successful,  _ALL0C  proceeds 
to  allocate  from  the  recycled  memory,  otherwise  execution  halts  with  an  error. 

3.1.1  Data  Tagging 

Any  garbage  collector  need-s  to  be  able  to  distinguish  pointers  into  the  heap  from 
miscellaneous  integer  v'Jues  in  the  machine’s  registers.  This  is  a  run-time  determi¬ 
nation,  and  there  axe  many  ways  that  the  compiler  can  help  the  garbage  collector  do 
this.  The  way  used  in  the  /xFX/DLX  compiler  is  that  of  tagging  values  at  run-time. 
This  relies  on  the  convention  that  all  data  objects  be  aligned  on  even-byte  boundaries 
(ours  are  aligned  on  four-byte-boundaries) 

The  tag  of  a  (4-byte)  data  item  is  its  lowest  bit.  Our  tagging  convention  is  that 
integers  have  a  low  bit  of  zero,  while  a  pointer  into  the  heap  or  stack  has  a  low  bit  of 
one.  This  means  the  compiler  has  to  adhere  to  two  more  conventions  so  that  things 
all  work.  First,  every  integer  n  (and  every  atom  representable  in  a  single  word)  is 
represented  by  2  x  n.  This  makes  the  low  bit  of  every  integer  a  zero  at  the  cost  of 
decreasing  the  range  of  the  integers  we  can  represent  and  of  complicating  the  code 
for  multiplication  and  di/ision  (addition  and  subtraction  work  unchanged).  Second, 
every  pointer  is  represented  by  a  word  value  that  is  one  (byte)  greater  than  the 
address  of  the  object  pointed-to.  Since  all  objects  are  even-byte  aligned,  this  makes 
all  pointers  (which  did  have  a  low  bit  of  zero)  have  a  low  bit  of  one.  The  cost  is  that 
every  memory  reference  through  a  pointer  p  must  be  adjusted  at  run-time  to  be  a 
reference  through  p  —  1. 

Executable  code  in  our  model  resides  neither  in  We  heap  nor  in  the  stack,  so 
pointers  into  the  code  (such  as  return  addresses)  are  never  tagged.  This  agrees  nicely 
with  the  semantics  of  DLX’s  jump-and-link  instruction. 

In  the  compiler  code,  the  function  otag  (offset  tag)  provides  a  convenient  way  to 
name  a  slot;  if  p  is  a  tagged  pointer,  p  +  otag(-l)  is  the  machine  address  of  the  size 
slot,  p  +  otag(O)  is  the  machine  address  of  the  first  data  slot,  etc. 

3.1.2  Stack  conventions 

The  stack  is  organized  as  a  stack  of  four  byte  slots.  Thus,  the  stack  pointer  is  always 
moved  in  increments  of  four  bytes.  The  stack  register  always  contains  the  untagged 
address  of  the  first  free  slot  on  the  stack.  The  stack  grows  downward  in  the  DLX 
address  space. 

Stack  allocation  of  a  block  is  done  by  subtracting  the  size  of  the  object  to  be 
pushed  in  bytes,  including  the  size  slot  from  the  stack  pointer.  A  properly  tagged 
pointer  to  the  resulting  block  is  the  new  stack  pointer  plus  five.  The  runtime  routine 
-SALLOC  allocates  and  zeroes  a  block  on  the  stack  and  accumulates  statistics  about 
stack  space  usage. 
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3.2  Calling  convention 


3.1.3  Garbage  collection 

Storage  management  is  based  upon  a  stop- and- copy  garbage  collector.  In  this  scheme, 
The  heap  is  divided  into  two  equal-sized  semispaces.  At  any  time,  one  is  considered 
“active”  and  the  other  “empty”.  Every  heap  allocation  is  made  from  the  active 
semispace.  When  the  memory  allocator  finds  that  the  active  semispace  has  filled 
up,  it  calls  the  garbage  collector.  The  garbage  collector  swaps  the  active  and  empty 
semispaces,  then  scans  all  blocks  pointed-to  by  any  register  and  any  blocks  transitively 
accessible  from  any  scanned  block.  It  copies  all  of  these  accessible  blocks  into  the 
(newly)  active  semispace.  The  garbage  collector  does  not  copy  any  memory  block  that 
is  inaccessible,  or  any  memory  block  on  the  stack  (although  any  accessible  blocks  on 
the  stack  are  scanned  to  discover  new  pointers  into  the  heap). 

The  registers  which  start  the  copying  process  are  called  the  root  set.  The  root 
set  includes  all  user  data  registers,  the  frame  pointer,  the  environment  pointer,  and 
the  temporary  VAL  register.  These  registers  are  discussed  further  in  section  3.2. 
Of  course,  any  register  or  block  slot  that  does  not  contain  a  tagged  pointer  is  not 
considered  to  be  a  pointer  by  the  garbage  collector. 

Note  that  if  a  block  in  the  stack  is  not  reachable  from  the  root  set  then  it  will 
not  be  scanned  by  the  garbage  collector.  It  is  therefore  safe  to  put  data  on  the 
stack  that  is  not  in  the  standard  memory  block  format,  as  long  as  this  data  does  not 
include  pointers  which  must  be  examined  by  the  garbage  collector.  This  is  useful 
when  writing  the  assembly  code  routines  that  interface  to  the  operating  system. 


3.2  Calling  convention 

The  caller  is  responsible  for  preserving  the  values  of  all  registers  except  for  VAL, 
ATEMP,  and  RETADR.  Registers  are  saved  in  activation  frames,  which  axe  linked 
dynamically  and  form  the  “dynamic  chain.”  The  head  of  the  dynamic  chain  is  pointed 
to  by  the  frame  pointer  register  FP  (a  tagged  pointer). 

Before  each  procedure  call,  an  activation  frame  is  allocated  and  linked  into  the 
dynamic  chain.  All  registers  (except  VAL,  ATEMP,  and  RETADR)  are  saved  in  this 
activation  frame.  Arguments  to  the  procedure  are  evaluated  and  placed  in  registers 
ARGO,  ARG1,  etc. 

By  convention,  at  the  time  of  a  procedure  call,  register  ARGO  holds  a  pointer  to 
the  procedure  being  called  and  ARGn  holds  the  nth  formal.  When  the  procedure  is 
called,  the  return  address  is  stored  into  slot  2  of  the  activation  record.  The  layout  of 
the  activation  record  is  indicated  in  Figure  3.  The  live  registers  are  restored  from  the 
current  activation  frame  and  computation  continues. 

At  the  end  of  a  procedure  body,  the  callee  places  the  result  in  the  VAL  register 
and  jumps  to  the  return  address  stored  in  the  activation  frame.  When  the  callee 
returns,  the  caller  restores  the  stack  pointer  and  frame  pointer  registers.  Figure  4 
shows  the  register  usage  of  the  /iFX/DLX  runtime  system. 

3.2.1  Representation  of  Environments 

^FX/DLX  environments  axe  represented  in  memory  by  chains  of  blocks  (called  ribs). 
Indices  1  through  n  of  each  rib  contain  n  values  of  a  lexical  environment’s  variables, 
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Offset 

T 

0 

1 

2 

3 

4 

5 


Contents _ 

frame  size 
FP  (dynamic  chain) 

SP  (before  frame  was  pushed!) 

return  address 

ENV 

r6 

r7 


27 


r29 


Comment 

Caller  saves  these  registers.  Put 
into  frame  when  it  is  first  alloc’d 
before  a  procedure  invocation. 

Caller  saves  these  registers  by  invoking 
.SAVE  just  before  arguments  to 
callee  are  evaluated.  Restored  after 
called  procedure  returns. 


Figure  3:  The  Frame  Layout 


Mnemonic 

Machine  register  number  and  Use 

ZERO 

0 

Always  zero  —  hardware  convention 

VAL 

1 

Val  ret’d  by  proc,  scratch,  no  one  saves 

ENV 

2 

Pointer  to  head  of  static  chain,  caller  saves 

FP 

3 

Pointer  to  head  of  dynamic  chain,  caller  saves 

SP 

4 

Stack  pointer,  cailler  saves 

HP 

5 

Heap  pointer,  only  used  by  ALLOC  and  GC 

ARGO 

6 

Compiler  temp,  used  to  pass  closure,  caller  saves 

ARG1 

7 

Compiler  temp,  used  to  pass  1st  argument,  caller  saves 

ARG2 

7 

Compiler  temp,  used  to  pass  2nd  argument,  calie'  vives 

ARG3 

8 

...ditto  for  register  up  to  and  incl.  r29... 

ATEMP 

30 

Scratch,  pass  args  to  system  routines,  no  one  saves 

RETADR 

31 

Used  as  scratch,  no  one  saves 

Figure  4:  DLX  Register  Usage 


16 


3  THE  RUNTIME  ENVIRONMENT 


3.2  Calling  convention 


RIB  2 


ENV 

reg 


RIB  1 


block 


1 — ► 

f 

6 

RIB  3 


a 

b 


-block  - 
arbitrary 

1 

2 


Figure  5:  Example  of  Environment  Representation 


and  index  0  contains  a  pointer  to  the  parent  environment.  For  example,  consider  a 
set  of  three  nested  let  expressions: 

(let  ((a  1) 

(b  2)) 

(let  ((c  3) 

(d  4) 

(e  5)) 

(let  ((f  6)) 

Ibody  )  )  ) 


When  /body  is  evaluated,  the  environment  structure  is  represented  hv  tt-  nf 

blocks  shown  in  Figure  5.  The  variable  names  shown  in  Figure  j  are  not  tAp,..K  ' 
represented  in  the  environment  structure,  only  their  values  are.  The  names  are  shown 
in  the  figure  for  documentation  purposes  only. 

Variables  are  accessed  by  traversing  ribs  “backward”  until  the  proper  rib  is  found, 
then  by  indexing  “over”  to  set  or  retrieve  the  proper  value.  Thus,  each  accessible 
variable  may  be  referenced  from  a  code  location  by  knowing  only  its  “back”  and 
“over”  numbers.  The  compiler  automatically  maintains  such  numbers  and  does  this 
for  the  user.  In  icode,  a  variable  reference  is  encoded  by  the  low-level  primitive 
(var  back  over).  In  figure  5,  f  is  (var  0  1),  c  is  (var  1  1),  d  is  (var  1  2),  e 
is  (var  1  3),  a  is  (var  2  1),  and  b  is  (var  2  2).  In  compiled  code,  (var  x  y) 
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translates  to  x  indirect  references  through  the  environment  pointer  followed  by  an 
indexed  access  to  the  y-th  component  of  that  block. 

4  Some  Suggested  Experiments 

We  have  come  up  with  a  set  of  possible  projects  that  illustrate  various  problems  in 
compilation,  some  of  which  are  in  use  here  at  MIT.  Our  list  includes: 

•  Implementing  stack  allocation  of  frames  and  of  environments  when  analysis 
shows  this  to  be  possible. 

•  The  (re- implementation  of  any  one  of  the  existing  compiler  phases  (type  re¬ 
construction  and  code  generation  are  good  candidates). 

•  Replacing  static  links  with  displays. 

•  Allocating  closures  statically,  or  eliminating  their  construction  altogether  when 
analysis  shows  this  to  be  possible. 

•  Modify  activation  record  allocation  to  save  only  the  registers  which  are  live  at 
the  time  of  the  call. 

•  Modify  heap  allocation  to  be  performed  inline  instead  of  always  calling  _ALLOC. 

•  Adding  new  language  features. 

Further  ideas  for  easy  yet  illustrative  experiments  for  students  would  be  valued. 


5  Obtaining  the  Distribution  in  Electronic  Form 

Our  system  may  be  obtained  via  anonymous  ftp  from  host  brokaw.lcs.mit.edu  in 
the  directory  pub/microfx.  The  package  includes  documentation,  the  compiler,  run¬ 
time  library,  ocode  interpreter,  and  a  compiler  test  suite.  Mini  FX  avjjlal  '  na 
anonymous  ftp  from  the  same  host. 

Appendices  C  and  D  contains  the  source  code  of  the  compiler  and  the  run-time 
library.  This  material  is  indexed  by  procedures,  types,  and  variable  names  at  the  end 
of  this  report.  This  appendix  represents  a  snapshot  as  of  February  12,  1992  of  the  25 
Mini-FX  source  files  which  are  available  via  FTP. 

The  simulator  for  DLX  may  be  obtained  via  anonymous  ftp  from  the  host  max  .  Stanford .  edu, 
in  pub/hennessy-patterson. software,  and  is  included  in  the  pub  micro  .'x 
bution. 


A  The  DLX  Instruction  Set 

This  appendix  contains  a  brief  description  of  the  DLX  instruction  set,  as  used  in 
H FX/DLX.  This  description  is  based  on  the  assembler  and  interpreter  supplied  with 
dlxsim. 
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A.l  Registers  and  Miscellajiy 


A.l  Registers  and  Miscellany 


32  32-bit  integer  registers  (r0..r31);  rO  always  reads  as  0.  32  32-bit  Soating-pt  registers 
(f0..f31)  (doubles  use  even-odd  pairs).  There  are  no  condition  code  bits.  DLX  has 
load  interlocks.  All  loads  and  stores  trap  on  unaligned  access. 


A. 2  Integer  Instructions 


Operator 

Operands 

Comment 

add 

d,sl,s2 

[traps  on  overflow] 

addi 

d,s,il6 

[traps  on  overflow]  (sign-extended  il6  DATA) 

addu 

d,sl,s2 

addui 

d,s,il6 

and 

d,sl,s2 

andi 

d,s,il6 

beqz 

r,  label 

branch  if  reg  is  zero. 

bnez 

r,  label 

branch  if  reg  is  non-zero. 

j 

label 

jal 

label 

leaves  address  of  instr  after  delayed  instr  in  i  > . . 

jr 

r 

s&3=0  else  trap. 

jalr 

r 

s&3=0  else  trap,  ret  address  like  jsr. 

lb 

d,il6(s) 

(sign-extended  il6  OFFSET)  sxt  data  byte  to  word 

lbu 

d,il6(s) 

(sign-extended  il6  OFFSET)  zeroes  high  bits 

lh 

d,il6(s) 

(sign-extended  il6  OFFSET)  sxt  data  halfword  to  word 

lhi 

d,il6 

load  immediate  halfword  <<16.  zeroes  low  16  bits 

lhu 

d,il6(s) 

(sign-extended  il6  OFFSET)  zeroes  high  bits 

lw 

d,il6(s) 

(sign-extended  il6  OFFSET) 

nop 
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Operator  Operands  Comment 


or 

d,sl,s2 

ori 

d,s,il6 

sb 

il6(s),d 

(sign-extended  il6  OFFSET) 

seq 

d,sl,s2 

seqi 

d,s,il6 

(sign-extended  il6  DATA) 

sequ 

d,sl,s2 

same  as  seq 

sequi 

d,s,il6 

different  from  seqi  (no  sign-ext  of  imm  data  here) 

sge 

d,sl,s2 

sgei 

d,s,il6 

(sign-extended  il6  DATA) 

sgeu 

d,sl,s2 

sgeui 

d,s,il6 

sgt 

d,sl,s2 

sgti 

d,s,il6 

(sign-extended  il6  DATA) 

sgtu 

d,sl,s2 

sgtui 

d,s,il6 

sh 

il6(s),d 

(sign-extended  il6  OFFSET) 

sle 

d,sl,s2 

slei 

d,s,il6 

(sign-extended  il6  DATA) 

sleu 

d,sl,s2 

sleui 

d,s,il6 

sll 

d,sl,s2 

slli 

d,s,il6 

sit 

d,sl,s2 

slti 

d,s,il6 

(sign-extended  il6  DATA) 

situ 

d,sl,s2 

sltui 

d,s,il6 

sne 

d,sl,s2 

Operator 

Operands 

Comment 

snei 

d,s,il6 

(sign-extended  il6  DATA) 

sneu 

d,sl,s2 

same  as  sne 

sneui 

d,s,il6 

different  from  snei  (no  sign-ext  of  imm  data  here) 

sra 

d,sl,s2 

srai 

d,s,il6 

srl 

d,sl,s2 

srli 

d,s,il6 

sub 

d,sl,s2 

(traps  on  overflow) 

subi 

d,s,il6 

(traps  on  overflow)  (sign-extended  il6  DATA) 

subu 

d,sl,s2 

subui 

d,s,il6 

sw 

il6(s),d 

(sign-extended  il6  OFFSET) 

trap 

i27 

xor 

d,sl,s2 

xori 

d,s,il6 
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A. 3  Pseudo-Integer  Instructions 


Operator 

Operands  Comment 

div 

fd,fsl,fs2  traps  on  div-by-zero 

divu 

fd,fsl,fs2  traps  on  div-by-zero 

movfp2i 

d,f 

movi2fp 

f,r 

mult 

fd,fsl,fs2  traps  on  overflow 

multu 

fd,fsl,fs2  traps  on  overflow 

A. 4  Floating  Point  Instructions 

Operator 

Operands  Comment 

addd 

Fd,Fsl,Fs2 

addf 

fd,fsl,fs2 

bfpf 

label 

bfpt 

label 

cvtd2f 

f,F 

cvtd2i 

f,F 

cvtf2d 

F,f 

cvtf2i 

fl,f2 

cvti2d 

F,f 

cvti2f 

fl,f2 

divd 

Fd,Fsl,Fs2 

divf 

fd,fsl,fs2 

eqd 

F1,F2 

eqf 

fl,f2 

ged 

F1,F2 

gef 

fl,f2 

gtd 

F1,F2 

gtf 

fl,f2 

Id 

F,il6(s)  (sign-extended  il6  OFFSET) 

led 

F1,F2 

lef 

a,f2 

If 

f,il6(s)  (sign-extended  il6  OFFSET) 

ltd 

F1,F2 

ltf 

fl,f2 

movd 

F1,F2 

movf 

fl,f2 

multd 

Fd,Fsl,Fs2 

multf 

fd,fsl,fs2 

ned 

F1,F2 

nef 

fl,f2 

sd 

il6(s),F  (sign-extended  i  1 6  OFFSET) 

sf 

il6(s),f  (sign-extended  il6  OFFSET) 

subd 

Fd,Fsl,Fs2 

subf 

fd,fsl,fs2 
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B  fiFX/DLX  Run-Time  Library 


This  appendix  contains  a  listing  of  the  standard  library  routines  supported  by  the 
runtime  system  of  /zFX/DLX.  This  is  a  subset  of  the  FX-91  standard  library. 


Name 

Type 

Comment 

symbol 

(->  (name)  symbol) 

builtin  constructor 

and 

(->  (bool  bool)  bool) 

builtin  operator 

or 

(->  (bool  bool)  bool) 

builtin  operator 

backspace 

char 

constant 

newline 

char 

constant 

page 

char 

constant 

space 

char 

constant 

tab 

char 

constant 

equiv? 

(->  (bool  bool)  bool) 

and? 

(->  (bool  bool)  bool) 

or? 

(->  (bool  bool)  bool) 

not? 

(->  (bool)  bool) 

not 

(->  (bool)  bool) 

char«? 

(->  (char  char)  bool) 

char<? 

(->  (char  char)  bool) 

char>? 

(->  (char  char)  bool) 

char<=? 

(->  (char  char)  bool) 

char>*? 

(->  (char  mar)  bool) 

char-ci=»? 

(->  (char  char)  bool) 

char-ci<? 

(->  (char  char)  bool) 

char-ci>? 

(->  (char  char)  bool) 

char-ci<*? 

(->  (char  char)  bool) 

char-ci>«? 

(->  (char  char)  bool) 

char- alphab et i c ? 

(->  (char)  bool) 

char-numeric? 

(->  (char)  bool) 

char-whitespace? 

(->  (char)  bool) 

char-lower-case? 

(->  (char)  bool) 

char-upper-case? 

(->  (char)  bool) 

char-upcase 

(->  (char)  char) 

char-downcase 

(->  (char)  char) 

char->int 

(->  (char)  int) 

int->char 

(->  (int)  char) 

22 


B  nFX/DLX  RUN-TIME  LIBRARY 


Name _ Type _ _ _ _ 

*  (->  (int  int)  bool) 

<  (->  (int  int)  bool) 

>  (->  (int  int)  bool) 

<=  (->  (int  int)  bool) 

>=  (->  (int  int)  bool) 

+  (->  (int  int)  int) 

(->  (int  int)  int) 

(->  (int  int)  int) 

/  (->  (int  int)  int) 

remainder  (->  (int  int)  int) 

modulo  (->  (int  int)  int) 

neg  (->  (int)  int) 

abs  (->  (int)  int) 

null?  (generic  (t)  (->  ((listof  t))  bool)) 

null  (generic  (t) 

(->  ()  (listof  t))) 
cons  (generic  (t) 

(->  (t  (listof  t))  (listof  t))) 
cax  (generic  (t) 

(->  ((listof  t))  t)) 

cdr  (generic  (t) 

(->  ((listof  t))  (listof  t))) 
set-car!  (generic  (t) 

(->  ((listof  t)  t)  unit)) 

set-cdr!  (generic  (t) 

(->  ((listof  t)  (listof  t))  unit)) 
length  (generic  (t) 

(->  ((listof  t))  int)) 

append  (generic  (t) 

(->  ((listof  t)  (listof  t))  (listof  t))) 


Comment 

builtin  predicate 
builtin  predicate 
builtin  predicate 
builtin  predicate 
builtin  predicate 
builtin  operator 
builtin  operator 
builtin  operator 
builtin  operator 
builtin  operator 
builtin  operator 
builtin  operator 
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Name  Type  Comment 


reverse 

(generic  (t) 

(->  ((listof  t))  (listof  t))) 

list-tail 

(generic  (t) 

(->  ((listof  t)  int)  (listof  t))) 

list-ref 

(generic  (t) 

(->  ((listof  t)  int)  t)) 

map 

(generic  (tl  t2) 

(->  ((->  (tl)  t2)  (listof  tl))  (listof  t2))) 

f or-each 

(generic  (tl  t2) 

(->  ((->  (tl)  t2)  (listof  tl))  unit)) 

reduce 

(generic  (tl  t2) 

(->  ((->  (tl  t2)  t2)  (listof  tl)  t2)  t2) ) 

list->string 

(->  ((listof  char))  string) 

string->list 

(->  (string)  (listof  char)) 

pair 

(generic  (tl  t2)  (->  (tl  t2)  (pairof  tl  t2))) 

left 

(generic  (tl  t2)  (->  ((pairof  tl  t2))  tl)) 

right 

(generic  (tl  t2)  (->  ((pairof  tl  t2))  t2)) 

ref 

(generic  (t)  (->  (t)  (ref of  t))) 

(generic  (t)  (->  ((ref of  t))  t)) 

;  a 

(generic  (t)  (->  ((ref of  t)  t)  unit)) 

make-string 

(->  (int  char)  string) 

string-length 

(->  (string)  int) 

string-ref 

(->  (string  int)  char) 

string-set ! 

(->  (string  int  char)  unit) 

string-fill ! 

(->  (string  char)  unit) 

string*? 

(->  (string  string)  bool) 

string<? 

(->  (string  string)  bool) 

string>? 

(->  (string  string)  bool) 

string<*? 

(->  (string  string)  bool) 

string>=? 

(->  (string  string)  bool) 

string-ci=? 

(->  (string  string)  bool) 

string-ci<? 

(->  (string  string)  bool) 

string-ci>? 

(->  (string  string)  bool) 

string-ci<*? 

(->  (string  string)  bool) 

string-ci>»? 

(->  (string  string)  bool) 

substring 

(->  (string  int  int)  string) 

string-append 

(->  (string  string)  string) 

string-copy 

(->  (string)  string)  ; 

string->vector 

(->  (string)  (vectorof  char)) 

vector->string 

(->  ((vectorof  char))  string) 
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Name _ 

sym-> string 
string->sym 
sym*? 
hash 

make-vector 
vector-length 
vector-ref 
vector-set ! 
vector-fill ! 
vector->list 
list->vector 
vector-map 


vector-map2 


vector-reduce 

scan 

segmented 


compress 

expand 


eoshift 


Type  _ Comrne 

(->  (sym)  string) 

(->  (string)  sym) 

(->  (sym  sym)  bool)  built 

(->  (sym)  int) 

(generic  (t)  (->  (int  t)  (vectorof  t))) 

(generic  (t)  (->  ((vectorof  t))  int)) 

(generic  (t)  (->  ((vectorof  t)  int)  t)) 

(generic  (t)  (->  ((vectorof  t)  int  t)  unit)) 

(generic  (t)  (->  ((vectorof  t)  t)  unit)) 

(generic  (t)  (->  ((vectorof  t))  (listof  t))) 

(generic  (t)  (->  ((listof  t))  (vectorof  t))) 

(generic  (tl  t2) 

(->  ((->  (tl)  t2)  (vectc  of  tl)) 

(vectorof  t2))) 

(generic  (tl  t2  t3) 

(->  ((->  (tl  t2)  c3)  (vectorof  tl)  (vectorof  t2)) 

(vectorof  tS))'' 

(gen  si'.  (*1  t2)  (->  ((->  (tl  t2)  t2)  (vectorof  tl)  t2) 
z2.  J 

(generic  (t)  (->  ((->  (t  t)  t)  (vectorof  t)) 

(ve  tcrof  t) ) ) 

(generic  (t) 

(->  ((->  (t  t)  t)  (vectorof  bool)  (vectorof  t)) 

(vectorof  t))) 

(generic  (tl)  (->  ((vectorof  bool)  (vectorof  t)) 

(vectorof  t))) 

(generic  (tl) 

(->  ((vectorof  bool)  (vectorof  t)  (vectorof  t)) 

(vectorof  t))) 

(generic  (tl)  (->  (int  (vectorof  t)  (vectorof  t)) 

(vectorof  t))) 
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Name 

unparse-bool 

unparse-char 

unparse-int 

unparse-string 

unparse- symbol 

unparse-unit 

unparse-list 

unparse- vector 

unparse-pair 


Type _ 

(->  (bool)  string) 

(->  (char)  string) 

(->  (int)  string) 

(->  (string)  string) 

(->  (sym)  string) 

(->  (unit)  string) 

(generic  (t) 

(->  ((->  (t)  string)  (listof  t))  string)) 
(generic  (t) 

(->  ((->  (t)  string)  (vectorof  t))  string)) 
(generic  (r  1) 

(->  ((->  (1)  string) 

(->  (r)  string) 

(pairof  r  1)) 
string)) 


Comment 


C  /zFX/DLX  Compiler  Implementation 

This  appendix  contains  a  snapshot  as  of  February  12,  1992  of  the  17  source  files 
which  implement  the  compiler  and  ocode  simulator  in  Mini-FX.  All  of  these  files  axe 
available  via  FTP. 

The  files  included  in  this  appendix  axe  as  follows: 


Filename 

Module 

Purpose 

compiler/asm.fx 

Support 

Assemble  and  unpaxse  ocode  representation 

compiler/bits  .fx 

Support 

Low-level  data  manipulation  utilities 

compiler/dlxsim.fx 

Emulate 

Emulation  support 

compiler/exp.fx 

Parse 

(iFX  parse  tree  definition 

compiler/  exp2ic.fx 

Translate 

Translate  expressions  to  intermediate  code 

compiler/ic2oc.fx 

Generate 

Generate  ocode  by  recursive  descent  of  icode 

compiler/icode.fx 

Generate 

Icode  representation  definition 

compiler/lib.fx 

Runtime 

Definitions  of  /iFX  primitives 

compiler/misc.fx 

Support 

Miscellaneous  utilities 

compiler /oc2t  xt .  fx 

Output 

Produce  DLX  assembly  code  text 

compiler/ocode .  fx 

Generate 

Ocode  representation  definition 

compiler/optimize.fx 

Optimize 

Optimization  of  intermediate  code 

compiler/ parse. fx 

Parse 

Parse  /iFX  Syntax 

compiler  /  system.fx 

Emulate 

Garbage  collector  and  allocator  for  ocode  emulation 

compiler/ table.fx 

Support 

Symbol  table  utility 

compiler/ toplevel.fx 

Support 

Top-level  user  ir'erface  to  /iFX/PT.X 

compiler/ty_recon.fx 

Reconstruct 

Type  reconstruction  algorithm 

The  index  at  the  end  of  this  document  contains  entries  for  procedures,  shared  vari¬ 
ables,  and  runtime  entry  points. 
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C.  1  com  piler/asm.fx 


C.l  compiler/ asm.  fx 


The  contents  of  the  file  compiler/ asm. fx: 


;;  Hod* :  Scheme;  Package:  SCHEME  -*- 

;;  asm .fx  —  assemble  and  nnparse  ocode  from  code  generator.  “Assemble" 
;;  means  prepare  lor  emulation;  unparse  means  prepare  lor  output  to  lile 
;;  lor  dlrsim  assembler. 

;;  Ve  lactor  instructions  according  to  the  type  ol  operands  they  use. 

;;  The  lolloping  shorthands  are  used  to  name  these  types:  i  =  integer 
;;  register;  c  =  integer  constant;  1  =  single-precision  FP;  g  =  double 
;;  FP;  d  =  integers  in  FP  registers  (e.g.,  lor  div  instruction). 

; ;  The  two  lunctions  exported  by  this  lile  are  asm-ocode  and 
;;  unparse-ocode.  asm-ocode  takes  an  operation  name  (symbol)  and  a 
;;  set  ol  operands  and  returns  a  thunk  that,  when  applied,  mutates  the 
;;  state  ol  the  DLX  machine  (see  dlxsim.lx)  according  to  the 
; ;  instruction,  unparse-ocode  takes  an  operation  name  and  set  ol 
; ;  'rands  and  returns  a  string  representing  the  instruction  in 
;;  ollicial  DLX  assembler  syntax. 

; ;  asm-ocode  and  unparse-ocode  use  asm-???  (assemble)  and  unp-??? 

;;  (unparse)  lunctionals  lor  dillerent  classes  ol  instructions.  The 
;;  asm-???  lunctionals  return  a  thunk  which,  when  applied,  mutates  ■ 

; ;  DLX  machine  state  according  to  the  instruction.  The  asm-??? 

;;  lunctionals  try  to  do  expensive  operations  (e.g.,  matches  on 
;;  operands)  in  an  environment  enclosing  the  returned  thunk.  The 
; ;  unp-???  lunctionals  return  a  string  which  is  the  unparsing  ol  the 
; ;  operation. 

(deline  unp-oname 
(lambda  (op) 

(let  ((oname  (down-sym  op))) 

(string-append  oname  (pad  oname  3))))) 
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C  pFX/DLX  COMPILER  IMP  LEM  E  S  T.A  T 10  X 


(define  unparse-reg 

( lambda  (ra) 

(if  (“  *rr-pretty*) 

(cond  ((=  ra  ZERO)  •'ZERO") 

((*  ra  VAL)  "VAL") 

((*  ra  EIV)  "ESV") 

((=  ra  FP)  -FP-) 

((»  ra  SP)  "SP") 

((*  ra  ARGO)  "ARGO*1) 

((=  ra  ARG1)  "ARG1") 

(0*  ra  ARG2)  " ARG2") 

((*  ra  ARG3)  "ARG3") 

((*  ra  ARG4)  “ARG4") 

((*  ra  ARGS)  "ARGS") 

((*  ra  ARG6)  "ARG6") 

((=  ra  ARG7)  "ARG7") 

((=  ra  ARG8)  "ARG8" ) 

((=  ra  ATEMP)  "ATEMP”) 

((=  m  RETADR)  “RET ADR”) 

(else  (string-append  "r”  (int->string  ra) )) ) 
(string-append  "r”  (int->string  rn))))) 

(define  unparse-freg 

(lambda  (n)  (string-append  "f"  (int->string  n)))) 

(define  unparse-dreg 

(lambda  (n)  (string-append  "f"  (int->string  n) ) ) ) 

(define  asm-iii 

;;  Three  integer  registers  (e.g.,  add,  subu) 

(lambda  (fn  rands) 

(match  rands 
((rrr->rand s”  d  si  s2) 

(lambda  ()  (set-reg!  d  (fn  (get-reg  si)  (get-reg  s2)))))))) 

(define  unp-iii 
(lambda  (op  rands) 

(let  ((oname  (unp-oname  op))) 

(match  rands 
((rrr->rands'  d  si  s2) 

(string-append  oname  (unparse-reg  d)  ”,  ”  (unparse-reg  si)  ",  " 
(unparse-reg  s2))))))) 


(define  asm-iic 

;;  Two  int  reg’s  and  a  constant  (e.g.,  xori) 

(lambda  (fa  rands) 

(match  rands 
( (rri->rands*  d  si  s2) 

(let  ((val  (eval-imaed  s2))) 

(lambda  ()  (set-reg!  d  (fn  (get-reg  si)  val)))))))) 


28 


C  fiFX/DLX  COMPILER  IMPLEMENTATION _ C.l  compiler/ asm. fx 


(define  unp-iic 
(lambda  (op  rands) 

(let  ((oname  (unp-oname  op))) 

(match  rands 
((rri->rands*  d  si  s2) 

(string-append  oname 

(unparse-reg  d)  ",  "  (unparse-reg  si)  ",  "  a2)))))) 

(define  asm-bl 

;;  Branches  that  take  one  operand  (e.g.,  jal,  bfpf) 

(lambda  (fn  rands) 

(match  rands 
((i->rands'  1) 

(let  ((val  (eval-immed  1))) 

(lambda  0  (:=  *npc*  (fn  val))))) 

((r->rands*  r) 

(lambda  ()  (:=  *npc*  (fn  r))))))) 

(define  unp-bl 

(lambda  (op  rands) 

(let  ((oname  (unp-oname  op))) 

(match  rands 

((i->rands"  1)  (string-append  oname  1)) 

((r->rands"  r)  (string-append  oname  (unparse-reg  r))))))) 

(define  asm-b2 

;;  Branches  that  take  two  operands  (e.g.,  bneq) 

(lambda  (fn  rands) 

(match  rands 
((ri->rands"  r  1) 

(let  ((val  (eval-immed  1))) 

(lambda  ()  (:=  *npc*  (fn  r  val)))))))) 

(define  unp-b2 

(lambda  (op  rands) 

(let  ((oname  (unp-oname  op))) 

(match  rands 

((ri->randa"  r  1)  (string-append  oname  (unparse-reg  r)  ",  "  1)))))) 
(define  asm-load 

; ;  ill  load  instructions  except  lhi  and  FP  loads 
(lambda  (fn  rands) 

(match  rands 

((load->rands*  d  offset  base) 

(lambda  () 

(set-reg!  d  (fn  (get-mem  (+  offset  (get-reg  base)))))))))) 
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C  nFX/DLX  COMPILER  IMPLEMEXTATIOS 


(define  asp-load 
(lambda  (op  rands) 

(1st  (Conans  (unp-onaus  op))) 

(natch  rands 

((load->rands*  d  of at  bass) 

(string-appsnd  onans 

(onparse-reg  d)  ",  " 

(int->string  ofst)  “(“  (unparss-reg  base)  ")")))))) 

(del ins  asn-lhi 
(lambda  (rands) 

(match  rands 
((ri->rands*  d  s) 

(let  ((val  (*  (eval-immed  s)  two*16))) 

(lanbda  ()  (set-reg!  d  val))))))) 

(define  onp-lhi 
(lanbda  (op  rands) 

(match  rands 

((ri->rands*  d  a)  (string-append  "lhi  "  (anparse-reg  d)  ",  "  s))))) 
(define  asn-store 

; ;  ill  store  instructions  except  FP  stores 
(lanbda  (fn  rands) 

(natch  rands 

((store->rands*  offset  base  v) 

(lambda  () 

(let*  ((addr  (+  offset  (get-reg  base))) 

(old-val  (get-man  addr)) 

(val  (get-reg  v))) 

(set-men!  addr  (fn  old-val  val)))))))) 

(define  onp-store 
(lanbda  (op  rands) 

(let  ((onane  (nnp-oname  op))) 

(match  rands 

((store->rands*  ofst  base  v) 

(string-append  onane 

(int->string  ofst)  ”("  (unparse-reg  base)  "),  '• 
(unparse-reg  v))))))) 


(define  asn-fff 

;;  Instructions  taking  three  single  FP  registers  (e.g.,  addf) 
(lanbda  (fn  rands) 

(natch  rands 
((rrr->rands*  d  si  s2) 

(lanbda  ()  (set-freg!  d  (fa  (get-freg  si)  (get-freg 
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(daiina  unp-iii 

(lambda  (op  rands) 

(1st  ((onama  (unp-oname  op))) 

(match  rands 
((rrr->rands*  d  *1  s2) 

(string-append  onama  (unparsa-lrag  d)  ",  "  (unparse-ireg  si)  ", 
(unparse-ireg  s2))))))) 


(daiina  asm-ggg 

;;  Instructions  taking  three  doubla  FP  rag’s  (a.g.,  divd) 

(lambda  (In  rands) 

(match  rands 
( (rrr->randa*  d  al  *2) 

(lambda  ()  (sat-drag!  d  (in  (gat-dreg  si)  (gat-drag  s2)))))))) 

(daiina  unp-ggg 
(lambda  (op  rands) 

(let  ((onama  (unp-oname  op))) 

(match  rands 
((rrr->rands"  d  si  s2) 

(atring-appand  onama  (nnparsa-drag  d)  ",  "  (unparse-dreg  si)  ",  » 
(unparaa-dreg  s2))))))) 


(daiina  aam-ip-ral 

; ;  Floating  point  ralational  operations  modiiy  tha  ip  boolean  ilag 
(lambda  (in  c  rands) 

(let  ((gat  (cond  ((sym=?  c  ’f)  gat-irag)  ((sym=?  c  ’g)  get-drag)))) 

(match  rands 
(Crr->rands"  si  s2) 

(lambda  ()  (:*  *ip-cond*  (in  (gat  si)  (gat  s2))))))))) 

(daiina  unp-fp-rel 
(lambda  (op  c  rands) 

(lat  ((unp  (cond  ((sym=?  c  ’i)  unparse-ireg)  ((sym=?  c  ’g)  unparsa-dreg))) 
(onama  (unp- onama  op))) 

(match  rands 
((rr->rands*  si  s2) 

(lambda  ()  (string-append  onama  (unp  si)  (unp  s2) ))))))) 

(daiina  aam-cnv 

(lat  ((gat  (lambda  (c)  (cond  ((or  (sym=?  c  ’d)  (sym=?  c  ’!))  gat-irag) 

((sym=?  c  ’g)  gat-dreg) 

((sym=?  c  ’i)  get-rag)))) 

(at!  (lambda  (c)  (cond  ((or  (sym=?  c  ’d)  (sym=?  c  ’!))  set-ireg!) 

( (sym=?  c  ’g)  set-dreg!) 

((sym=?  c  ’i)  sat-rag! ))))) 

(lambda  (in  d  s  rands) 

(let  ((g  (gat  s))  (s!  (st!  d))) 

(match  rands 

((rr->rands*  dst  src)  (lambda  ()  (s!  dst  (in  (g  src) )))))))) ) 
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(define  nnp-cnv 

(let  ((unp  (lambda  (c)  (coad  ((or  (sym=?  c 

((sym*?  c  ’g) 
((sym»?  c  ’i) 

(lambda  (op  d  s  raada) 

(lot  ((onama  (unp-oaama  op))) 

(match  raada 
((rr->randa*  dat  arc) 

(atriag-appand  onama  ((uap  d)  dat) 


’d)  (aym=?  c  ’f))  unparse-freg) 
unpara e-dr eg) 
unparaa-rag) ) ) ) ) 


",  "  ((unp  a)  arc)))))))) 


Fuactioaa  that  are  applied  to  operanda  (represented  as  bigauma)  to 
execute  low-level  ALU  ops  and  return  the  result  (another  bignum) . 
These  functions  are  used  only  than  the  minifx  equivilant  doesn't  do 
the  right  thing,  such  aa  when  when  dealing  with  the  inidividual 
bits  of  a  signed  integer. 


(define  mk-bsise 

;;  Takas  an  operation  (e.g.,  and?)  and  applies  it  bit-visa  to  the  bits 
;;  in  the  operands.  Since  se  store  the  operanda  in  bignum  rather 
;;  than  machine  int  format,  ee  need  to  convert  the  operands  to 
;;  machine  int a  to  make  sure  negative  numbers  are  handled  correctly, 
(lambda  (op) 

(lambda  (vail  va!2) 

(letrec  ((loop 

(lambda  (x  vl  v2  i) 

(if  (=  i  32) 

(mint2bignum  x) 

(loop  (♦  x  (if  (op  (odd?  vl)  (odd?  v2))  (expt  2  i)  0)) 
(quotient  vl  2) 

(quotient  v2  2) 

(♦  i  1)))))) 

(loop  0  (bignum2mint  vail)  (bignum2mint  val2)  0))))) 

;;  For  relational  operators,  must  return  1  or  0  rather  than  #t  or  #f 
(define  mk-alu-rel 

(lambda  (fn)  (lambda  (x  y)  (if  (fn  x  y)  1  0)))) 


(define  mk-alu-urel  ;;  For  unsigned  operands 

(lambda  (fn)  (lambda  (x  y)  (if  (fn  (bignum2mint  x)  (bignum2mint  y))  1  *)))) 


(define  mk-alu-sgn  ; ;  For  signed  integer  operators 
(lambda  (fn)  (lambda  (x  y)  (let  ((result  (fn  x  y))) 

(if  (int32?  result) 
result 

(error  "ALU  overflov")))))) 


(define  mk-alu-unsgn  ; ;  For  unsigned  integer  operators 
(lambda  (fn) 

(lambda  (x  y) 

(mint2bignum  (remainder  (fn  (bignum2mint  x)  (bignum2mint  y))  two“32))''' 
(define  alu-neq  (lambda  (x  y)  (if  (=  x  y)  0  1))) 
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C.  1  compiler  asm jx 


(dsiia*  alu-xor  (ak-buiss  (lambda  (x  y)  (or  (and  x  (not  y))  (aad  (not  x)  y))))) 
(d**ia*  alu-or 

; ;  Tb*  cod*  generator  u***  an  or  instruction  sith.  the  RO  register  as 
;;  aovss,  so  s«  want  tint  case  to  go  last. 

(lambda  (x  y) 

(cond  ((*  x  0)  y) 

((■  y  0)  x) 

(sis*  ((mk-bsis*  or?)  x  y))))) 

(dslias  alu-s-lstt-1  (lambda  (x  y)  (*  x  (sxpt  2  y)))) 

(define  alu-s-right-1 

(lambda  (x  y)  (mint2bignum  (quotient  (bignum2mint  x)  (sxpt  2  y))))) 

(define  alu-s-rigbt-a 
(lambda  (x  y) 

(mint2bignum  (+  (quotient  (bignum2mint  x)  (sxpt  2  y)) 

(it  (<  x  0)  tuo‘31  0))))) 
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C  pFX/DLX  COMPILER  IMPLEMENTATION 


(del in*  asm 
(lambda  (insn) 

(lat  ((op  (op-code  insn)) 

(rands  (op-rands  insn) ) ) 

(cond 

((sym=?  op  ’add)  (asm-iii  (mk-alu-sgn  +)  rands)) 

((sym=?  op  ’addi)  (asm-iic  (mk-alu-sgn  +)  rands)) 

( (sym=?  op  ’addu)  (asm-iii  (mk-alu-unsgn  +)  rands)) 

( (aym=?  op  ’addui)  (asm-iic  (mk-alu-unsgn  +)  rands)) 

((sym*?  op  ’and)  (asm-iii  (mk-bsise  and?)  rands)) 

((sym=?  op  ’andi)  (asm-iic  (mk-beise  and?)  rands)) 

((sym=?  op  ’or)  (asm-iii  alu-or  rands)) 

((sym=?  op  ’ori)  (asm-iic  alu-or  rands)) 

((sym=?  op  ’seq)  (asm-iii  (mk-alu-rel  =)  rands)) 

((sym*?  op  ’ seqi)  (asm-iic  (mk-alu-rel  =)  rands)) 

((sym=?  op  ’sequ)  (asm-iii  (mk-alu-urel  =)  rands)) 

((sym=?  op  ’sequi)  (asm-iic  (mk-alu-urel  =)  rands)) 

((sym*?  op  ’sge)  (asm-iii  (mk-alu-rel  >=)  rands)) 

((sym=?  op  ’sgei)  (asm-iic  (mk-alu-rel  >=)  rands)) 

( (sym*?  op  ’sgeu)  (asm-iii  (mk-alu-urel  >=)  rands)) 

((sym=?  op  ’sgeui)  (asm-iic  (mk-alu-urel  >=)  rands)) 

( (sym=?  op  ’sgt)  (asm-iii  (mk-alu-rel  >)  rands)) 

((sjrm=?  op  ’sgti)  (asm-iic  (mk-alu-rel  >)  rands)) 

((sym=?  op  ’sgtu)  (asm-iii  (mk-alu-urel  >)  rands)) 

((sym=?  op  ’sgtui)  (asm-iic  (mk-alu-urel  >)  rands)) 

((sym*?  op  ’sle)  (asm-iii  (mk-alu-rel  <=)  rands)) 

( (sym=?  op  ’slei)  (asm-iic  (mk-alu-rel  <=)  rands)) 

((sym*?  op  ’sleu)  (asm-iii  (mk-alu-urel  <*)  rands)) 

((sym=?  op  ’sleui)  (asm-iic  (mk-alu-urel  <=)  rands)) 

((sym*?  op  ’sll)  (asm-iii  alu-s-leit-1  rands)) 
((sym=?  op  ’slli)  (asm-iic  alu-s-left-1  rands)) 
((sym=?  op  ’sit)  (asm-iii  (mk-alu-rel  <)  rands)) 

((sym*?  op  ’slti)  (asm-iic  (mk-alu-rel  <)  rands)) 

((sym=?  op  ’situ)  (asm-iii  (mk-alu-urel  <)  rands)) 

( (sym*?  op  'sltui)  (asm-iic  (mk-alu-urel  <)  rands)) 

((sym*?  op  ’sue)  (asm-iii  alu-neq  rands)) 

((sym*?  op  ’snei)  (asm-iic  alu-neq  rands)) 

((sym*?  op  ’sneu)  (asm-iii  alu-neq  rands)) 

((sym*?  op  ’sneui)  (asm-iic  alu-neq  rands)) 

((sym*?  op  ’sra)  (asm-iii  alu-s-right-a  rands)) 
((sym*?  op  ’srai)  (asm-iic  alu-s-right-a  rands)) 
((sym*?  op  ’srl)  (asm-iii  alu-s-right-1  rands)) 
((sym*?  op  ’srli)  (asm-iic  alu-s-right-1  rands)) 
((sym*?  op  'sub)  (asm-iii  (mk-alu-sgn  -)  rands)) 

((sym*?  op  ’subi)  (asm-iic  (mk-alu-sgn  -)  rands)) 

((sym*?  op  ’subu)  (asm-iii  (mk-alu-unsgn  -)  rands)) 
((sym*?  op  ’subui)  (asm-iic  (mk-alu-unsn  -)  rands)) 
((sym*?  op  ’xor)  (asm-iii  alu-xor  rands)) 

((sym*?  op  ’xori)  (asm-iic  alu-xor  rands)) 


C  pFX/DLX  compiler  implementation 


C.l  compiler/ asm.  fx 


((sym=?  op  'beqz)  (aam-b2  (lambda  (r  d) 

(il  (=  (get-reg  r)  0)  d  C  *npc*))) 
randa ) ) 

((aym=?  op  ’blpt)  (asm-bl  (lambda  (d)  (il  (“  *lp-cond*)  (*  *npc*)  d)) 

randa ) ) 

((aym=?  op  ’blpl)  (asm-bi  (lambda  (d)  (il  (*  *lp-cond*)  d  (*  *npc*))) 

randa ) ) 

((aym=?  op  ’bnez)  (aam-b2  (lambda  (r  d) 

(il  (=  (get-reg  r)  0)  ('  *npc*)  d)) 
randa) ) 

((sjrm=?  op  ’j)  (asa-bl  id  randa)) 

((aym=?  op  ’jr)  (aam-bl  get-reg  randa)) 

((aym=?  op  ’jal)  (aam-bi  (lambda  (d) 

(begin  (aet-reg!  RETADR  (+  ('  *pc*)  4)) 

d)) 

randa ) ) 

((sym=?  op  ’jalr)  (aam-bl  (lambda  (r) 

(begin  (aet-reg!  RETADR  (+  ('  *pc*)  4)) 
(get-reg  r))) 

randa) ) 

aajrm=?  op  ’lb)  (aam-load  (lambda  (v)  (sert8->32  (remainder  v  two'8))) 

rands ) ) 

((sym=?  op  ’lbn)  (aam-load  (lambda  (v)  (remainder  ▼  two'8))  randa)) 

((sym=?  op  ’lb)  (aam-load  (lambda  (v) 

(aextl6->32  (remainder  v  two'16))) 
rands ) ) 

((sym=?  op  ’lbi)  (asm- lbi  randa)) 

((sym=?  op  ’lbn)  (asm-load  (lambda  (v)  (remainder  v  two'16))  randa)) 
((sym=?  op  ’lw)  (asm-load  id  rands)) 

((sym=?  op  ’ab)  (asm-store 

(let  ((In  (set-bit-lield  08))) 

(lambda  (ov  ▼)  (In  ov  (remainder  ▼  two'8)))) 
randa ) ) 

((sym*?  op  ’ab)  (asm-store 

(let  ((In  (set-bit-lield  0  16))) 

(lambda  (ov  v)  (In  ov  (remainder  v  twote))'’ 
rands ) ) 

((aym=?  op  ’aw)  (asm-store  (lambda  (ov  v)  v)  rands)) 

((sym=?  op  ’div)  (asm-111  quotient  randa)) 

((sym=?  op  ’divu)  no-emulate) 

((sym=?  op  ’mult)  (asm-111  (mk-alu-sgn  *)  rands)) 

((sym=?  op  ’multu)  no-emulate) 
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((sya=?  op  ’addd)  (asa-ddd  11+  rands)) 

((sym=?  op  ’addl)  (aaa-lll  11+  rands)) 

( (aya=?  op  ’divd)  (asa-ddd  11/  raads)) 

((aym=?  op  ’divl)  (asa-111  11/  rands)) 

((aya=?  op  ’eqd)  (asa-lp-ral  'g  11=  rands)) 

( (sym=?  op  ’eql)  (asa-lp-rel  \ 1  11=  rands)) 

( (aym=?  op  ’ged)  (asa-lp-ral  ’g  11>=  rands)) 

((sya=?  op  'gal)  (asa-lp-ral  '1  11>=  rands)) 

((aya=?  op  ’gtd)  (asa-lp-ral  ‘g  11>  rands)) 

((sya=?  op  ’gtl)  (asa-lp-ral  *1  11>  rands)) 

((aya=?  op  ’ltd)  (asa-lp-ral  'g  11<  rands)) 

((aym=?  op  ’ltl)  (asa-lp-ral  ’1  11<  rands)) 

((sya=?  op  ’led)  (asa-lp-rel  ’g  11<=  rands)) 

((sya=?  op  ’lei)  (asa-lp-rel  *1  11<=  rands)) 

((sya=?  op  ’aultd)  (asa-ddd  11*  rands)) 

((sya=?  op  ’aultl)  (asa-111  11*  rands)) 

((sya=?  op  ’ned)  (asa-lp-rel  ’g  (laabda  (x  y)  (not  (11=  x  y)))  rands)) 

((sya=?  op  ’nel)  (asa-lp-rel  ’1  (laabda  (x  y)  (not  (11=  x  y)))  rand3)) 

((sym=?  op  ’subd)  (asa-ddd  11-  rands)) 

((sya=?  op  ’snbl)  (asa-111  11-  rands)) 

((sym=?  op  ’Id)  no -emulate) 

( (sym=?  op  ’ll)  no-eaulata) 

( (aym=?  op  *sd)  no-emulata) 

((sya=?  op  ’si)  no-eanlate) 

((sym=?  op  ’trap)  no-eaulata) 

((sya=?  op  ’nop)  (laabda  ()  the-unit)) 

((sym=?  op  ’ cvtd21 )  (asa-cnv  id  ’1  ’g  rands)) 

((sya=?  op  ’cvtd2i)  (asa-cnv  id  'd  'g  rands)) 

((sya=?  op  1 cvt!2d)  (asa-cnv  id  ’g  *1  rands)) 

((sya=?  op  ’cvt!2i)  (asa-cnv  truncate  'd  ’1  rands)) 

((sym=?  op  ’cvti2d)  (asa-cnv  int->lloat  ’g  'd  rands  )) 

((sya=?  op  1 cvti21)  (asa-cnv  int->lloat  '1  'd  rands)) 

((sya=?  op  ’aovd)  (asa-cnv  id  ’g  ’g  rands)) 

((sym=?  op  ’aovl)  (asa-cnv  id  ’1  ’1  rands)) 

((sym=?  op  ’aovlp2i)  (asa-cnv  id  ’i  ’d  rands^' 

((sym=?  op  *aovi21p)  (asa-cnv  id  ’d  ’i  rands )),;)) 

(asa-inlo  ’aovi2s  ”0x00"  "0x30") 

(asa-inlo  *novs2i  "0x00"  "0x31") 

(asa-inlo  ’rle  "0x40"  "0x00") 
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(define  unparse-ocode 
(lambda  (insn) 

(let  ((op  (op-code  insn)) 

(rands  (op-rands  insn))) 

(cond 

((sym=?  op  ’labeldef) 

(string-append  (match  rands  ((label->rands*  1)  1))  '*:")) 

((sym=?  op  ’stringdef) 

(string-append  ".asciiz  V"  (match  rands  ((string->rands*  s)  s))  "V" 
(char->string  #\nealine)  ".align  2")) 

((sym=?  op  ’vorddef) 

(string-append  ".vord  " 

(int->string  (match  rands  ((vord->rands*  v)  v))))) 

((memq  op  ’(add  addu  and  or  seq  seqn  sge  sgau  sgt  sgtn  sle  slen 
sll  sit  situ  sne  sneu  sra  srl  sub  subu  xor) ) 

(unp-iii  op  rands)) 

((memq  op  ’(addi  addui  andi  ori  seqi  sequi  sgei  sgeui  sgti  sgtui  slei 

sleui  slli  slti  sltui  snei  sneui  srai  srli  subi  subui  xori)) 
(unp-iic  op  rands)) 

((memq  op  ’ (beqz  bnez))  (unp-b2  op  rands)) 

((memq  op  ’ (bf pt  bfpf  bnez  j  jr  jal  jalr))  (unp-bl  op  rands)) 

((memq  op  ’(lb  lbu  lh  lhu  Is))  (unp-load  op  rands)) 

((sym=?  op  ’lhi)  (unp-lhi  op  rands)) 

((memq  op  ’(sb  sh  ss))  (unp-store  op  rands)) 

((memq  op  * (div  divu  mult  multu))  (unp-fff  op  rands)) 

((memq  op  ’(addf  divf  multf  subf))  (unp-fff  op  rands)) 

((memq  op  ’(addd  divd  multd  subd))  (unp-ddd  op  rands)) 

((memq  op  ’(eqf  gef  gtf  Itf  lef  nef))  (unp-fp-rel  ’f  op  rands)) 

((memq  op  ’(eqd  ged  gtd  ltd  led  ned))  (unp-fp-rel  ’g  op  rands)) 

((sym=?  op  ’nop)  "nop") 

((sym=?  op  *cvtd2f)  (unp-cnv  op  ’f  ’g  rands)) 

((sym=?  op  ’cvtd2i)  (unp-cnv  op  ’d  ’g  rands)) 

((sym=?  op  ’cvtf2d)  (unp-cnv  op  ’g  ’f  rands)) 

( (sym=?  op  ’cvtf2i)  (unp-cnv  op  ’d  ’f  rands)) 

((sym=?  op  ’cvti2d)  (unp-cnv  op  ’g  ’d  rands)) 

((sym=?  op  ’cvti2f)  (unp-cnv  op  ’f  ’d  rands)) 

((sym=?  op  ’movd)  (unp-cnv  op  ’g  ’g  rands)) 

((sym=?  op  ’movf)  (unp-cnv  op  ’f  ’f  rands)) 

((sym=?  op  *movfp2i)  (unp-cnv  op  ’i  ’d  rands)) 

((sym=?  op  ’movi2fp)  (unp-cnv  op  ’d  ’i  rands)))))) 

;;  ((memq  op  ’(Id  If  sd  sf))  ??) 

;;  ((sym=?  op  ’trap)  ??) 


C.2  compiler/bits.fx 

The  contents  of  the  file  compiler/bits.fx: 

-*-  Mode:  Scheme;  Package:  SCHEME 
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Bit  banging  stuff 


(define  two'8  (expt  28)) 

(define  two* 15  (expt  2  15)) 

(define  two "16  (expt  2  16)) 

(define  two'31  (expt  2  31)) 

(define  two'32  (expt  2  32)) 

(define  intl6?  ;  (->  (int)  bool) 

(lambda  (n)  (and  (<=  n  (-  two'15  1))  (>=  n  (-  0  two'16))))) 

(define  int32? 

(lambda  (n)  (and  (<=  n  (-  two*31  1))  (>=  n  (-  0  two'31))))) 


(define  mk-bignum2mint 
(lambda  (size-in-bits) 

(let  ((two'n  (expt  2  size-in-bits))) 

(lambda  (bn)  (if  (>=  bn  0)  bn  (+  two'n  bn)))))) 

(define  bignum2mint  (mk-bignum2mint  32)) 

(define  mk-bignum2bits 
(lambda  (size-in-bits) 

(letrec  ((loop 

(lambda  (s  v  i) 

(if  (=  i  size-in-bita) 
s 

(loop  (string-append  (if  (odd?  v)  "1"  "0")  s) 
(quotient  v  2) 

(+  i  1)))))) 

(lambda  (bn)  (loop  HM  (bignum2signed  bn)  0))))) 

(define  bignum2bits  (mk-bignum2bits  32)) 

(define  mk-mint2bignum 
(lambda  (size-in-bita) 

(let  ((two'n  (expt  2  size-in-bits)) 

(two'n- 1  (expt  2  (-  size-in-bits  1)))) 

(lambda  (mi) 

(if  (<*  mi  (-  two*n-l  1))  mi  (-  mi  two'n)))))) 

(define  mint2bignum  (mk-mint2bignum  32)) 


(define  get-bit-field 

;;  bit-field  :  int  *  int  ->  (int  ->  int) 

; ;  Access  a  bit  field  of  an  integer. 

(lambda  (position  size) 

(let  ((shift  (expt  2  position)) 

(mask  (expt  2  size))) 

(lambda  (n) 

(remainder  (quotient  n  shift)  mask))))) 
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(define  set-bit-field 

;;  set-bit-field  :  int  *  int  ->  fiat  *  iat  ->  iat) 

;;  Initialize  a  bit  field  oi  an  integer.  Assumes  the  field  currently 
; ;  contains  zero,  because  we  don’t  need  to  clear  it  first  in  that  case, 
(lambda  (position  size) 

(let  ((shift  (expt  2  position)). 

(mask  (expt  2  size))) 

(lambda  (n  value) 

(if  (or  (<  value  0) 

(>=  value  mask)) 

(error  "bit  field  out  of  range"  position  size  n  value) 

(+  n  (*  value  shift))))))) 


;  Parse  and  unparse  hex  numbers  to  make  examination  of  bit-operations 
;  easier. 


(define  h2i 

;;  Convert  3tring  of  hex  numbers  into  integer.  Requires  3tring  to 
; ;  be  in  form  "Oxh..."  where  h  is  in  [0-9a-z] 

(letrec  ((loop 

(lambda  (s  i  v) 

(if  (=  i  (string-length  s)) 
v 

(let*  ((c  (string-ref  s  i)) 

(h  (if  (char-numeric?  c) 

(-  ( char- > int  c)  (char->int  #\0)) 

(+  (-  (char->int  c)  (char->int  #\a))  10)))) 
(loop  s  (+  i  1)  (+  (*  v  16)  h))))))) 

(lambda  (s)  (loop  s  2  0)))) 

(define  i2h 
(letrec  ((loop 

(lambda  (v  1) 

(if  (=  v  0) 

1 

(let*  ((h  (remainder  v  16)) 

(c  (if  (<=  h  9) 

(int->char  (+  h  (char->int  #\0))) 

(int->char  (+  (-  h  10)  (char->int  #\a)))))) 
(loop  (quotient  v  16)  (cons  c  1))))))) 

(lambda  (v) 

(if  (=  v  0) 

"0x0" 

(list->string  (cons  #\0  (cons  #\x  (loop  v  (null))))))))) 


C.3  compiler/dlxsim.fx 

The  contents  of  the  file  compiler/dlxsim.fx: 

;;  -*-  Mode:  Scheme;  Package:  SCHEME  -*- 
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C.  3  com  piler/dlxsim .  fx 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


; ;  Emulator  parameters 
(define  *samispace-size*  (ref  500)) 
(define  *stack-size*  (ref  500)) 
(define  *noisy-gc*  (ref  #t)) 

(define  *rr-pretty*  (ref  #t)) 

(define  *program-start*  (ref  0)) 
(define  *break-points*  (ref  (list))) 


;  Slots  in  each  space 
;  Slots  in  stack 

;  Pretty-print  registers 
;  Addr  of  1st  word  of  code 


; ;  Emulator  state 

(define  *entire-memory-size*  (ref  0)) 
(define  *mem*  (ref  (make-vector  0))) 
(define  *end-program*  (ref  0)) 

(define  *this-semispace*  (ref  0)) 
(define  *other-semispace*  (ref  0)) 
(define  *this-semispace-end*  (ref  0)) 
(define  *other-semispace-and*  (ref  0)) 


;  Total  words  in  sim'tor  mem 

;  Addr  of  last  word  of  code 
;  (Tagged)  address  of  first 
;  word  in  space 
;  (T’d)  address  of  1st  word 
;  beyond  last  word  in  3pace 


(define  *reg*  (generate-vector  32  (lambda  (index)  0))) 
(define  *freg*  (generate-vector  32  (lambda  (index)  0.0))) 
(define  *fp-cond*  (ref  0)) 

(define  *pc*  (ref  0)) 

(define  *npc*  (ref  0)) 

(define  *halt-emulate?*  (ref  #f)) 

(define  *label-table*  (ref  (null))) 


; ;  Emulator  statistics 

(define  *instruction-count*  (ref  0)) 

(define  *num-gcs*  (ref  0)) 

(define  *gc-words-copied*  (ref  0)) 
(define  etotal-allocation*  (ref  0)) 
(define  *total-allocs*  (ref  0)) 
(define  *max-stack-size*  (ref  0)) 


Routines  to  set  up  emulator 


; ;  Initialize  emulator 
(define  init-emulator 
(lambda  () 

(begin 

;;  First  pass  of  assembler:  get  name  of  ?.abels  and  find  out  length  of 
;;  program  coda. 

(:=  *label-table*  (null)) 

(enter-system-routine-labels)  ;  This  is  how  W6  saii  system  routines, 
(asm-pas si  (*  ocode-list))  ;  Calculate  values  of  labels 

; ;  Calculate  needed  memory  size 

(:=  *entire-memory-size*  (+  (quotient  (*  *end-program*)  4) 

(*  2  (*  *semispace-sxze*) ) 

(*  *stack-size*))) 
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c  ixFX/DLX  COMPILER  IMPLEMENTATION _ C.3  compiler /dlxsim.fx 


;;  Create  a  vector  to  represent  the  DLX  machine’s  memory.  II  required 
;;  memory  size  hasn't  grown  much  since  last  time,  then  don’t  cons  up 
;;  the  new  vector  so  we  avoid  generating  garbage. 

(let  ((old-len  (vector-length  (*  *mem*)))) 

(if  (or  (<  old-len  (*  *entire-memory-size*)) 

(>  (-  old-len  500)  (*  *entire-memory-size*) ) ) 

( : =  *mem* 

(generate-vector  (*  *entire-memory-size*)  (lambda  (i)  0))) 
(:=  *entire-memory-size*  old-len))) 

; ;  How  that  we  have  a  memory  vector,  assemble  code  into  that  vector 
(asm-pass2  (*  ocode-list)))))  ;  lssmbl  emulator  thunks  in2  mem  vec 

(define  restart-emulator 
(lambda  () 

(begin 

; ;  Zero  out  regis iters 

(letrec  ((loop  (lambda  (i)  (if  (>s  i  32) 

the-unit 

(begin  (set-reg!  i  0) 

(set-freg!  i  0.0) 

(loop  (♦  i  1))))))) 

(loop  0)) 

; ;  Initialize  important  system  registers 
(set-reg!  SP  (-  (*  (*  *entire-memory-size*)  4)  4)) 

(set-reg!  HP  (+  (*  * end-program*)  1)) 

(goto  ("  *program-start*))  ;  Set  pc  registers 
( : =  *halt-emulate?*  #1 ) 

; ;  Set  up  heap 

(:=  *this-semispace*  (get-reg  HP)) 

(:=  *this-semispace-end*  (+  (get-reg  HP)  (*  ("  *semispace-size*)  4))) 
(:=  *other-semispace*  (*  *this-semispace-end*)) 

( : =  *other-semispace-end* 

(+  ("  *other-semispace*)  (*  (*  *semispace-size*)  4))) 

; ;  Clear  statistics  variables 
(:=  *num-gcs*  0) 

(:=  *gc-words-copied*  0) 

( :=  *total-allocation*  0) 

(:*  *total-adlocs*  0) 

(:*  *instruction-count*  0) 

( : =  *max-stack-3ize*  0) 

; ;  Set-up  an  initial  frame  to  return  through 
(set-reg!  ATEMP  FrameSize) 

(allocate-block-of -memory) 

(set-reg!  FP  (get-reg  ATEHP)) 

(set-slot!  (get-reg  FP)  0  0) 

(set-slot!  (get-reg  FP)  1  SP) 

(set-slot!  (get-reg  FP)  2  -16)  ;  Return  to  _ EXIT  system  routine 

(set-slot!  (get-reg  FP)  3  0) 

(save-regs-into-frame) 
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C.3  compiler /dlxsim.fx 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


; ;  Set-up  an  inital  closure  lor  calling  START_1 
(set-reg!  ATEMP  4)  ;  2  uords  (tagged) 

(allocate-block-ol-memory) 

(set-reg!  ARGO  (get-reg  ATEMP))  ;  Create  dummy  closure 
(set-slot!  (get-reg  ARGO)  0  (*  *program-start*) ) 
(set-slot!  (get-reg  ARGO)  1  0)))) 


Routines  to  do  emulations  alter  machine  has  been  set  up 


(deline  emulate 
(lambda  () 

(begin  (emulate-one-instruction) 

(il  (*  *halt-emulate?*)  the-unit  (emulate))))) 

(deline  rerun 

;;  rerun  the  compiled  program  Irom  the  top... 

(lambda  ()  (begin  (restart-emulator)  (emulate)))) 

(deline  step 

;;  Single-step  program,  printing  out  instruction  just  emulated, 
(lambda  () 

(let  ((temp  (*  *verbose-llag*))) 

(begin  (:=  *verbose-llag*  #1) 

(display-one- instruct ion  (*  *pc*) ) 

(nstep  1) 

(display-one-instruction  (*  *pc*)) 

(:=  *verbose-llag*  temp))))) 


(deline  nstep 
(lambda  (n) 

(letrec  ((loop  (lambda  (i) 

(cond  ((>=  i  n)  the-unit) 

((*  *halt-emulate?*) 

(begin  (display  "Execution  terminated.") 
the-unit)) 

(else  (begin  (emulate-one-instruction) 
(loop  (+  i  1)))))))) 

(begin  (loop  0)  (dump))))) 


Two  passes  ol  assembler 
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C  n  FX/DLX  COMPILER  IMPLEMENTATION 


C.3  compiler/dlxsim.fx 


(define  asa-passl 

;;  Calculate  values  of  labels  and  enter  them  into  symbol  table.  Set 
;;  * end-pro gram*  to  (ontagged)  address  of  1st  word  after  program  code, 
(lambda  (ocode) 

(letrec  ((loop  (lambda  (ocode  pc) 

(if  (null?  ocode) 
pc 

(mated  (car  ocode) 

((ocode"  ’labeldef  (label->rands*  label)) 

(begin  (enter-label  label  pc) 

(loop  (edr  ocode)  pc))) 

((ocode"  ’stringdef  _)  (loop  (edr  ocode)  (+  pc  4))) 
(_  (loop  (edr  ocode)  (+  pc  4)))))))) 

(:=  *end-program*  (loop  ocode  ("  *program-start*)))))) 

(define  asm-pass2 

; ;  Place  emulation  thunks  into  memory 
(lambda  (ocode) 

(letrec  ((loop  (lambda  (ocode  pc) 

(if  (null?  ocode) 
the-unit 

(match  (car  ocode) 

((ocode"  ’labeldef  _)  (loop  (edr  ocode)  pc)) 
((ocode"  ’stringdef  (string->rands"  string)) 

(begin  (set-mem!  pc  string) 

(loop  (edr  ocode)  (+  pc  4)))) 

((ocode"  ’worddef  (word->rands"  word)) 

(begin  (set -mem!  pc  word) 

(loop  (edr  ocode)  (+  pc  4)))) 

(_ 

(begin  (set-mem!  pc  (asm  (car  ocode))) 

(loop  (edr  ocode)  (+  pc  4))))))))) 

(loop  ocode  0)))) 


Symbol  table  for  labels  —  set  up  for  two-way  mapping 


(define  enter-label 

(lambda  (1  v)  (:=  *label-table*  (cons  (tuple  1  v)  (*  *label-table*))))) 

(define  label2num 
(lambda  (1) 

(letrec  ((loop  (lambda  (1st) 

(cond  ((null?  1st)  (error  "Unknown  label  1)) 
((string=?  1  (tuple-ref  (car  1st)  0)) 
(tuple-ref  (car  1st)  1)) 

(else  (loop  (edr  1st))))))) 

(loop  (*  *label-table*))))) 
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C.3  compiler/ dlxsim.fx 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


(define  nun21abel 
(laabda  (a) 

(letrec  ((loop  (laabda  (1st) 

(coad  ( (aull?  1st)  ,,M) 

((=  a  (tuple-ref  (car  1st)  1)) 
(tuple-ref  (car  1st)  0)) 

(alsa  (loop  (cdr  1st))))))) 
(loop  (“  *label-table*))))) 


t  * 

; ;  Routiaas  to  change  stata  oi  aaalator  accordiag  to  instructions 
>  > 


(define  goto 

(laabda  (new-pc) 

(begia 

(if  (aaaq  aaw-pc  (*  *break-poiats*)) 

(arror  "Break-point:  typa  (procaeda)  to  contiaaa.’*)) 

(:*  *pc*  aaw-pc) 

(:=  *npc*  (+  aaw-pc  4))))) 

(define  aaalata-oaa-iaatractioa 
(laabda  () 

(begin 

(:=  *instruction-count*  (+  (*  *iastruction-count*)  1)) 

(if  (*  *verbos  e-flag* ) 

(display-ona-iastructioa  ('  *pc*)) 
the-unit) 

(if  (<  (*  *pc* )  0) 

(bagia 

;;  fake  system  subroutines  have  negative  addresses... 

;;  they’re  also  always  called  with  jal’s  (rataddr  ia  r31) 
(systea-routiaa  (*  *pc*))  ;  call  tha  service 

(goto  (gat-rag  RETADR)))  ;  fake  tha  return, 

(let  ((old-pc  (*  *pc*))) 

(bagia  (goto  (*  *npc*)) 

((get-nea  old-pc)))))))) 


»  » 

; ;  Procedures  to  access  and  change  emulator  stata 
»  » 


(define  get-nen 
(laabda  (address) 

(if  (=  (remainder  address  4)  0) 

(vector-ref  (*  *aea*)  (quotient  address  4)) 
(error  "Unaligned  read.")))) 

(define  set-nan! 

(laabda  (address  val) 

(if  (=  (remainder  address  4)  0) 

(vector-set!  (*  *aea*)  (quotient  address  4)  val) 
(error  "Unaligned  write.")))) 
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C  fiFX/DLX  COMPILER  IMPLEMENTATION 


C.3  compiler/dlxsim.fx 


(define  get-slot  (lambda  (ptr  slot)  (get-mem  (+  ptr  (otag  slot))))) 

(define  set-slot!  (lambda  (ptr  slot  v)  (set-mem!  (+  ptr  (otag  slot))  v))) 

(define  get-reg  (lambda  (regnum)  (vector-ref  *reg*  regnum))) 

(define  set-reg!  (lambda  (regnum  val)  (vector-set!  *reg*  regnum  val))) 
(define  get-freg  (lambda  (fregnum)  (vector-ref  *freg*  fregnum))) 

(define  set-freg!  (lambda  (fregnum  val)  (vector-set!  *freg*  fregnum  val))) 

(define  get-dreg 
(lambda  (fregnum) 

(if  (odd?  fregnum) 

(error  "Bad  double  register"  fregnum) 

(vector-ref  *freg*  fregnum)))) 

(define  set -dreg! 

(lambda  (fregnum  val) 

(if  (odd?  fregnum) 

(error  "Bad  double  register"  fregnum) 

(begin  (vector-set!  *freg*  fregnum  val) 

(vector-set!  *freg*  (+  fregnum  1)  -3.21))))) 

; ;  Routines  to  inspect  the  state  of  the  emulator 
(define  dump 

; ;  Display  register  values 
(lambda  () 

(letrec  ((cols  4)  (width  10) 

(loop  (lambda  (i) 

(if  (>»  i  32) 
the-unit 

(let  ((rval  (i2h  (get-reg  i)))) 

(begin 

(display  (pad  rval  width))  (display  rval) 

(if  («  (remainder  i  cols)  (-  cols  1)) 
(newline) 
the-unit) 

(loop  (♦  i  1)))))))) 

(begin  (newline)  (loop  0))))) 

(define  find-insn 
(lambda  (ocode  pc) 

(cond  ((sym=?  (op-code  (car  ocode))  ’labeldef) 

(find-insn  (edr  ocode)  pc)) 

((<*  pc  0)  (car  ocode)) 

((sym=?  (op-code  (car  ocode))  ’stringdef) 

(find-insn  (edr  ocode)  (-  pc  4))) 

(else  (find-insn  (edr  ocode)  (-  pc  4)))))) 
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C.  3  compiler/  dlx  fx 


C  pFX/DLX  COMPILER  IMP  LEM  E  STATION 


(deline  display-one-instruction 
(laabda  (pc-i) 

(il  (<  pc-i  0) 

(begin  (display  "*•**  ")  (display  (num21abel  pc-i))  (newline)) 

(1st  ((1  (mm2 label  pc-i))) 

(begin 

(newline) 

(il  (>  (string-length  1)  0) 

(begin  (display  "  **)  (display  1)  (display  ":")  (newline)) 

the-unit) 

(il  (<  pc-i  1000)  (display  "0”)  the-unit) 

(il  (<  pc-i  100)  (display  "0")  the-unit) 

(il  (<  pc-i  10)  (display  "0")  the-unit) 

(display  pc-i)  (display  “  '*) 

(display  (unparse-ocode  (lind-insn  (*  ocode-list)  pc-i)))))))) 

(deline  disasm  ;;  print  program  in  memory  (to  see  il  it’s  uncorrupted) 
(lambda  () 

(letrec  ((loop  (lambda  (i)  (il  (>=  i  (*  * end-program*) ) 

the-unit 

(begin  (display-one-instruction  i) 

(loop  (♦  i  4))))))) 

(loop  (*  *program-start*))))) 

(deline  pb  ; ;  print  heap  block 
(lambda  (p) 

(letrec  ((blksize  (de-itag  (get-slot  p  -1))) 

(loop  (lambda  (i) 

(il  (>*  i  blksize) 
the-unit 
(begin 

(display  (string-append 

”  +■•  (pad  (int->string  i)  3)  ”)) 

(display  (get-slot  pi)) 

(newline) 

(loop  (♦  i  1))))))) 

(begin 

(display  "Pointer®")  (display  p) 

(display  "  Blocksize®")  (display  blksize)  (newline) 

(loop  0))))) 
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C  nFX/DLX  compiler  implementation 


C.3  com  piler/  dlxsim.  fx 


;;  Evaluate  constant  expressions  in  operands  of  insn’s 

I  » 

(define  eval-immed 

;;  ...this  is  every*  crude,  but  sufficient  for  now... 

;;  Accept  the  following  grammar : 

; ;  expr : 

; ;  number 

; ;  -number 

; ;  LABEL 

; ;  LABEL  +  1 

; ;  (expr)  A  Oxffff 

; ;  (expr)»16 

;;  Very  little  error  cheeking  is  done... 

(lambda  (s)  (av-parse-expr  (ref  (av-tokenize  s))))) 

(define  av-parse-expr 
(lambda  (toks) 

(let  ((c  (string-ref  (car  C  toks))  0))) 

(cond 

((char=?  c  #\(  )  ;;  (expr)  ... 

(begin  (:3  toks  (cdr  (*  toks))) 

(mint2bignum  (avpe-recurse  toks)))) 

((char-numeric?  c)  ;;  number 
(let  ((n  (av-pars e-number  (car  (*  toks))))) 

(begin  (:=  toks  (cdr  (*  toks))) 
n))) 

((char3?  c  #\-)  ;;  -number 

(let  ((n  (-  (av-pars e-number  (cadr  (*  toks)))))) 

(begin  (:=  toks  (list-tail  (“  toks)  2)) 
n))) 

(else  ; ;  LABEL  f  LABEL  +  1 

(let  ((n  (label2num  (car  (*  toks))))) 

(if  (and  (>=  (length  (*  toks))  3) 

(char=?  (string-ref  (cadr  (*  toks))  0)  #\+))  ;;  LABEL  +  i 
(begin  (:  =  toks  (list-tail  (*  toks)  3)) 

(+  1  n)) 

(begin  (:*  toks  (cdr  ("  toks))) 
n)))))))) 


(define  avpe-recurse 
(lambda  (toks) 

(let  ((n  (bignum2mint  (av-parse-expr  toks)))) 

(if  (not  (char=?  (string-ref  (car  (*  toks"  ■  *' 
(error  "invalid  av-expr  syntax") 

(cond  ((char=?  (string-ref  (cadr  (“  toks))  0)  #\A) 
(begin  (:=  toks  (list-tail  (*  toks)  3)) 
(modulo  n  66536))) 

((char=?  (string-ref  (cadr  C  toks))  0)  #\>) 
(begin  (:=  toks  (list-tail  (*  toks)  3)) 
(quotient  n  65536))) 

(else  (error  "invalid  av-expr  syntax"))))))) 
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C.3  compiler/  dlxsim.fx 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


(define  av-parse-nuaber 

; ;  Assume  «a  got  a  decimal  number 
(lambda  (s) 

(letrec  ((loop 

(lambda  (n  i) 

(if  (=  i  (string-length  »)) 
n 

(loop  (+  (*  10  n) 

(-  (char->int  (string-ref  si))  (char->int  #\ 0))) 
(+  i  1)))))) 

(loop  0  0)))) 

;;  A  crude  lexer  for  a  crude  parser... 

(define  av-tokenize 

; ;  Real  simple  lexer  for  arithmatic  expressions  in  assembly  code 
(lambda  (s) 

(letrec  ((loop 

(lambda  (s  i) 

(let  ((j  (av-kill-whitespace  s  i))) 

(if  (>=  j  (string-length  s)) 

(null) 

(let  ((k  (av-next-tok  s  j))) 

(cons  (substring  s  j  k) 

(loop  s  k)))))))) 

(loop  s  0)))) 

(define  av-kill-whiteapace 
(lambda  (s  i) 

(if  (and  (<  i  (string-length  s))  (char-whitespace?  (string-ref  si))) 
(av-kill-whitespace  s  (+  i  1)) 
i))) 

(define  av-next-tok 
(lambda  (s  i) 

(let  ((c  (string-ref  s  i)) 

(len  (string-length  s))) 

(cond 

((char=?  c  #\()  (+  i  1)) 

((char=?  c  #\))  (+  i  1)) 

((av-sym?  c) 

(letrec  ((loop  (lambda  (i) 

(if  (or  (=  i  len)  (not  (av-sym?  (string-ref  s  i)))) 
i 

(loop  (+  i  1)))))) 

(loop  (+  i  1)))) 

((av-punct?  c) 

(letrec  ((loop  (lambda  (i) 

(if  (or  (=  i  len)  (not  (av-punct?  (string-ref  s  i)))) 
i 

(loop  (+  i  1)))))) 

(loop  (+  i  1)))))))) 
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C.4  compiler/ exp.  fx 


(define  av-sym? 

(lambda  (c)  (or  (char- alphabetic?  c)  (char-numeric?  c)  (char=?  c  #\_)))) 
(define  av-punct? 

(lambda  (c)  (and  (not  (av-sym?  c))  (not  (char=?  c  #\Q) 

(not  (char=?  c  #.\)))  (not  (char-vhitespace?  c))))) 


C.4  compiler/exp.fx 

The  contents  of  the  file  compiler/exp.fx: 

;  -*-  Mode:  Scheme:  Package:  SCHEME;  -*- 

;  Data  types  for  use  by  the  front-end  of  the  compiler 

;  (parser,  type  reconstructor,  exp2ic) 

;  Expressions 

(def ine-datatype  exp 

(variable->exp  (refof  type)  sym) 

(bool->exp  (refof  type)  bool) 

(char->exp  (refof  type)  char) 

(int->exp  (refof  type)  int) 

(string->exp  (refof  type)  string) 

(sym->exp  (refof  type)  sym) 

( conditional ->exp  (refof  type)  exp  exp  exp) 
(begin->exp  (refof  type)  (listof  exp)) 
(abstraction->exp  (refof  type)  (listof  sym)  exp) 
(combination->exp  (refof  type)  exp  (listof  exp)) 
(binder->exp  (refof  type)  (listof  definition)  exp) 
(recursion->exp  (refof  type)  (listof  definition)  exp) 
) 

(define  express ion-type 
(lambda  (exp) 

(match  exp 

((variable->exp*  type-ptr  _)  (*  type-ptr)) 
((bool->exp"  _  _)  boolean-type) 

((char->exp*  _  _)  character-type) 

((int->exp‘  _  _)  integer-type) 

((string->exp"  _ )  string-type) 

((sym->exp"  _  _)  symbol-type) 

( (conditional->exp*  type-ptr  _  _)  ('  type-ptr)) 

( (begin->exp*  type-ptr  _)  (*  type-ptr)) 

((abstraction->exp*  type-ptr  _ )  (*  type-ptr)) 

((combination->exp"  type-ptr  _ )  (*  type-ptr)) 

((binder->exp"  type-ptr  _  _)  (*  type-ptr)) 
((recursion->exp"  type-ptr  _  _)  (*  type-ptr)) 

))) 


(def ine-datatype  definition  ;  (IE) 
(make-definition  sym  exp)) 


I 

Bool 

Char 

Int 

String 
(symbol  Sym) 

(if  El  E2  E3) 

(begin  El  . . . ) 
(lambda  (I*)  E) 

(EO  E*) 

(let  ((I  E)*)  E) 
(letrec  ((I  E)*)  E) 
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C.  4  com  piier/exp .  fx 


C  fiFX/DLX  COMPILER  IMPLEMENTATION 


(define  (definition-name  d) 

(match  d 

((make-definition'  name  value)  name))) 

(define  (definition- value  d) 

(match  d 

((make-definition'  name  value)  value))) 


;  Types 

(def ine-datatype  type 

(base->type  sym)  ;  base  type  (bool,  int,  string,  symbol,  unit) 

(tvariable->type  tvariable)  ;  type  variable 

(compound->type  sym  ;  ->,  listof,  etc. 

(listof  type)) 

(unknown->type)  ;  marking  yet  unconstrained  type  variables 

) 

(define  boolean-type  (base->type  (symbol  bool))) 

(define  character-type  (base->type  (symbol  char))) 

(define  integer-type  (base->type  (symbol  int))) 

(define  string-type  (base->type  (symbol  string))) 

(define  symbol-type  (base->type  (symbol  sym))) 

(define  unit-type  (base->type  (symbol  unit))) 

(define  unknown-type  (unknown->type ) ) 

(define  same-constructor?  eq?) 

(define  arrow-constructor  (symbol  ->)) 

(define  make-arrow-type 

(lambda  (arg-types  body-type) 

(compound->type  arrow-constructor  (cons  body-type  arg-types)))) 

(define  arrow-takea 
(lambda  (ty) 

(match  ty 

((compound->type*  ’->  (cons'  bt  at))  at)))) 

(define  arrow-returns 
(lambda  (ty) 

(match  ty 

((compound->type"  ’->  (cons'  bt  at))  bt)))) 

(define  is-arrow-type? 

(lambda  (ty) 

(match  ty 

((compound->type*  ’->  _)  #t) 

(_  #f)))) 


;  Type  names  are  symbols 
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C  nFX/DLX  COMPILER  IMPLEMENTATION 


C.5  compiler/ exp2ic.fx 


(define  same-name?  aym=?) 


;  Type  schemas 

(define-datatype  schema 

(make-schema  (listof  tvariable)  type)) 

(define-datatype  tvar-or- schema 
(tvar->tvar-or-schema  tvariable) 
(schema->tvar-or-schema  schema)) 

(define  (schema-generics  s) 

(match  s 

((make-schema*  generics  typ)  generics))) 

(define  (schema-type  s) 

(match  s 

((make-schema*  generics  typ)  typ))) 


;  Unit  valne 

(define  the-unit  (:  =  (ref  0)  0)) 


C.5  compiler/exp2ic.fx 

The  contents  of  the  file  compiler/exp2ic.fx: 

;;  -*-  Mode:  Scheme;  Package:  SCHEME  -*- 
;;  erp2ic.fx  —  convert  ezpr’s  to  icode. 

;;  Depth-first,  syntax-driven  translation  of  expressions  into 
;;  intermediate  code.  The  depth-first  translation  is  stack  hungry, 

;;  but  we  don’t  expect  extremely  deep  expressions. 

;;  The  resulting  intermediate  code  it  stored  on  the  list  "icode-list." 
; ;  The  order  of  the  icode  on  this  list  is  preserved  in  the  ultimate 
;;  machine  code,  i.e.,  the  order  of  the  list  represents  flow  of 
;;  control  through  the  icode. 

;;  One  tricky  part  is  how  to  generate  code  for  lambda’s  and  letrec’s 
; ;  because  the  code  for  the  body  does  not  belong  in-line  with  the  call 
;;  to  the  body.  To  handle  this,  we  have  a  list  called 
; ;  "icode-to-be-emitted"  which  is  a  list  of  blocks  of  icode  to  be 
;;  emitted  later.  When  a  lambda  body  is  compiled,  the  icode  for  the 
;;  body  is  put  on  the  icode-to-be-emitted  list,  while  the  icode  for 
;;  the  closure  is  put  into  the  current  block  of  icode. 


(define  icode— list  (ref  (null)))  ;  intermediate  code  collected  on  this  list 
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C.5  compiler/exp2ic.£x 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


(define  generate-icode 
(laabda  (exp) 

(let*  ((ignore  (reset-label-counter) ) 

(at art label  (new-label  "START"))) 

(begin 

(lib-init) 

( : =  icode-to-be-emitted  (null)) 

( : =  library-icode  (null)) 

( : =  library-count  0) 

(:=  sym-label-env  (mk-empty-env  add-sym)) 

; ;  Initialize  icoda  list  with  translation  of  a  return  of  the 
; ;  top-laval  expression  along  with  a  label  for  tbe  start  of 
; ;  the  program . 

(:=  icode-list 

(list  (labeldef->icoda  startlabel) 

(retum->icode  (translate  exp  standard-c-t-env)))) 

;;  Translating  the  top-level  expression  caused  some  code, 

;;  e.g.,  the  bodies  of  lambda’s  and  letrec’s,  to  be  put  on 
;;  an  auxilary  list  to  be  emitted  latter,  low's  the  time  to 
; ;  emit  it . 

(emit-delayed-ic)) ) ) ) 


(define  icode-to-be-emitted 

; ;  Icode  to  be  emitted  later  is  put  on  this  list  in  blocks .  A  block 
;;  is  a  list  of  icode.  Each  block  is  emitted  in  order,  i.e.,  the 
;;  order  of  the  list  specifies  control  flow.  lo  order  between  blocks 
; ;  is  guaranteed.  Usually  each  block  starts  with  a  labeldef->icode  so 
;;  that  other  blocks  can  refer  to  it. 

(ref  (null))) 


(define  emit-ic-later 
(lambda  (codelist) 

(:=  icode-to-be-emitted  (cons  codelist  (*  icode-to-be-emitted));); 


(define  emit-delayed-ic 
(lambda  () 

(letrec  ((flatten  ;  turns  a  list  of  lists  into  a  list 
(lambda  (iclist-list  iclist) 

(if  (null?  iclist-list) 
iclist 

(flatten  (cdr  iclist-list) 

(append  (car  iclist-list)  iclist)))))) 


(begin 


(:=  icode-list  (append  (*  icode-list) 

(flatten  (*  icode-to-be-emitted)  (null)})) 
(:  =  icode-list  (append  (*  icode-list) 

(flatten  (*  library- icode)  (null)))))))) 
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C  nFX/DLX  COMPILER  IMPLEMENTATION  C.5  compiler /expXcSx 


(define  library-icode 

;;  The  library  functions  also  generate  delayed  icode.  To  make  the  output 
;;  clearer  (i.e.,  to  hide  the  ugly  library  stuff  at  the  end  of  the  outputed 
;;  code),  we  put  the  library  icode  on  a  separate  list.  Before  translating 
;;  library  code,  call  swap-delayed-icode-lists  to  snap  the 
;;  icode-to-be-emitted  list  with  another  list  for  library  code.  Vhen  the 
;;  library  code  is  done,  the  lists  should  be  swapped  back. 

(ref  (null))) 

(define  library-count 

;;  Wien  compiling  library  code,  we  may  have  to  compile  other  library 
;;  procedures.  To  make  sure  that  the  delayed  icode  list  gets  set 
;;  back  to  the  user’s  list  when  we  stop  compiling  library  code,  we 
; ;  keep  count  of  how  deep  we  are  into  compiling  libray  calls  within 
; ;  library  calls . 

(ref  0)) 

(define  swap-delayed-icode-lists 
(lambda  () 

(let  ((tmp  (*  icode-to-be-emitted))) 

(begin  (:=  icode-to-be-emitted  (*  library-icode) ) 

(:  =  library-icode  tmp))))) 

(define  enter-library 
(lambda  () 

(begin  (if  (=  0  (*  library-count))  (swap-delayed-icode-lists)  the-unit) 

(:=  library-count  (♦  (*  library -count)  1))))) 

(define  leave-library 
(lambda  () 

(begin  (:=  library-count  (-  (*  library-count)  1)) 

(if  (=  0  (*  library-count))  (swap-delayed-icode-lists)  the-unit)))) 
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C.o  compiler/ exp2ic.£x 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


Top-level  dispatch  f or  translation 


(define  translata 

(lambda  (axp  c-t-env) 

(match  exp 

((int->axp‘  _  n) 

( (char->arp"  _  c) 

((bool->exp*  _  b) 

((string->exp*  _  s) 

((sym->exp*  _  s) 
((variable->exp*  tr  var) 
((conditional->exp"  tr  t  c  a) 
((begin->exp‘  tr  exprs) 
((combination->axp*  tr  op  args) 
((abstraction->axp'  tr  args  b) 
((binder->exp“  tr  dais  b) 
((recursion->exp"  tr  dais  b) 


(trans-integer  n)) 

(trans-intagar  (char->int  c))) 
(trans-intager  (ii  b  1  0))) 

(trans-string  a)) 

(trans-symbol  a)) 

(trans-variable  c-t-anv  (*  tr)  var)) 
(trans-conditional  c-t-anv  (*  tr)  tea)) 
(trana-begin  c-t-anv  (“  tr)  exprs)) 
(trans-call  c-t-anv  (*  tr)  op  args)) 
(trans-lambda  c-t-anv  (*  tr)  args  b)) 
(trans-let  c-t-anv  (“  tr)  dais  b)) 
(trans-letrec  c-t-anv  (*  tr)  dais  b))))) 


; ;  Integers 

i  » 

(define  trans-intagar  (lambda  (n)  (int->icode  integer-type  n))) 


; ;  String 
>  » 

(define  trans-string 

;;  Since  strings  are  vectors  of  characters,  ve  need  a  say  to  translate 
; ;  a  string  literal  into  a  vector.  Ve  do  this  by  making  a  symbol  out 
;;  of  the  string  literal,  and  using  the  sym->string  to  build  the  char 
;;  vector  at  run-time.  (sym->string  is  in  lib.fx) 

(lambda  (s) 

(let  ((s2s-type  (parse-type  ’(->  (sym)  string)))) 

(translate  (combination->exp  ; ;  combination 

(ref  string-type)  ; ;  this  is  its  type 
(variable->exp  (ref  s2s-type)  ’sym-> string. 

; ;  this  is  the  function  being  called 
(list  (sym->exp  (ref  symbol-type)  (string->sym  s)))) 

;;  these  are  the  arguments. 

standard-c-t-env) ) ) ) 


; ;  (symbol  lame) 

»  » 

(define  trans-symbol 
(lambda  (s) 

(labelref->icode  symbol-type  ((*  sym-label-env)  s)))) 
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C  pFX/DLX  COMPILER  IMPLEMENTATION  C.5  compiler/exp2ic.fx 


(define  add- a  yin 

; ;  If  symbol  not  already  in  the  environment ,  then  make  a  label  for 
;;  it  and  pat  the  new  label  in  the  environ.  Look  in  table. 2x  to  see 
;;  how  mk-empty-env  and  mk- binder  work. 

(lambda  (key) 

(let  ((label  (new-label  ”SYK"))) 

(begin 

(emit-ic-later  (list  (labelde2->icode  label)  (sym->icode  key))) 

(:  =  sym-label-env  ( (mk-binder  sym=?)  key  label  (*  sym-label-env) ) ) 
label)))) 

(define  sym-label-env  (ref  (mk-empty-env  add-sym))) 


; ;  Identifiers 

»  » 

(define  trans-variable 
(lambda  (c-t-env  ty  var) 

(match  (c-t-lookup  c-t-env  var) 

; ;  compile  a  normal  var  ref  as  its  access  path.. . . 

( (back+over->binding"  back  over)  (var->icode  ty  back  over)) 

; ;  but  compile  prims  as  if  they  were  (lambda  (x  y)  (+  x  y)). 
((primitive->binding*  prim) 

(if  (prim-constant?  prim) 

(prim-constant-form  prim)  ;;  For  space,  newline,  etc.  constants 
(prim-closure-form  prim))))))  ;;  For  primitive  routines  (e.g.,  +) 


;;  (if  El  E2  E3) 

•  • 

(define  trans-conditional 

(lambda  (c-t-env  ty  tat  con  alt) 

(op->icode  ty  ’if  (list  (translate  tst  c-t-env) 

(translate  con  c-t-env) 

(translate  alt  c-t-env))))) 

; ;  (begin  E*) 

f  l 

(define  trans-begin 

(lambda  (c-t-env  ty  exprs) 

(op->icode  ty  ’begin  (map  (lambda  (x)  (translate  x  c-t-env;,  «xpxs 
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C.5  compiler/ exp2ic.£x 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


; ;  (lambda  (I*)  E)  —  create  a  procedure 

I  * 

(deline  trans-lambda 

(lambda  (c-t-env  ty  fonnals  body) 

(let  ((label  (new-label  "LAMBDA"))) 

(begin 

;;  1.  Translate  body  but  emit  it  later. 

(emit-ic-later  (list  (labeldefsicode  label) 

(body->icode 

ty 

(length  formal 3 ) 

(retum->icode 

(translate  body  (c-t-bind  formals  c-t-env)))))) 
; ;  2.  Translate  the  creation  of  the  closure  nos 
(trans-closure  ty  label))))) 

(define  trans-closure 

;;  The  EIV  reg  is  defined  (as  a  reg  number)  in  backend/gen . fx 
(lambda  (ty  proc-label) 

(alloc->icode  ty  2  (list  (labelref->icode  unknown-type  proc-label) 

(reg->icode  unknown-type  EIV))))) 


;;  (let  ((I  E)*)  EO) 

;;  For  now,  compile  this  as  ((lambda  I*  EO)  E*); 

; ;  Can  be  fancier  in  the  future 

(define  trans-let 

(lambda  (c-t-env  ty  defs  body) 

(let  ((names  (map  definition-name  defs)) 

(vals  (map  definition- value  defs))) 

(translate  (combinations exp 

(ref  (expression-type  body)) 

(abstract ion->exp 

(ref  (make-arrow-type  (map  expression-type  vals) 

(expression-type  body))) 

names 

body) 

vals) 

c-t-env) ) ) ) 
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C  pFX/DLX  COMPILER  IMPLEMENTATION 


C.5  compiler/exp2ic.fx 


;;  (letrec  ((I  E)*)  EO) 

;;  The  EIV  rag  is  defined  (as  a  rag  number)  in  backend/gen.fr 

(del in#  trans-latrac 

(lambda  (c-t-env  ty  dais  body) 

(let*  ((label  (new-label  "LETREC")) 

(new-env  (c-t-bind  (map  definition-name  defs)  c-t-env)) 

(trans-vals  (lambda  (d)  (translate  d  new-env)))) 

(begin 

;;  1.  Translate  the  body  of  the  letrec,  but  emit  it  later 
(emit-ic-later 

(list  (labeldei->ieode  label) 

(letrec->icode 
(length  dais) 

(map  trans-vals  (map  def inition-value  defs)) 

(retum->icode  (translate  body  new-env))))) 

;;  2.  Translate  a  call  to  the  letrec  body 
(op->icode  ty 

'call 

(list  (trans-closure  (make-arrow-type  ’()  ty)  label))))))) 


; ;  (EO  E*) 

*  » 

(define  trans-call 

(lambda  (c-t-env  ty  op  operands) 

(match  op 

((variable->exp"  _  var) 

(match  (c-t-lookup  c-t-env  var) 

( (primitive->binding*  prim) 

>  > 

;;  Yes,  all  this  vas  to  pull  out  this  one  case. 

;;  Primitives  get  compiled  in-line  instead  of  as  calls. 

I  t 

(trans-primitive-combination  ty  prim  operands  c-t-env)) 

(_  (trams -unknown-combination  ty  op  operands  c-t-  env)))) 

(_  (trans-unknown-combination  ty  op  operands  c-t-  env))))) 

(define  trans-primitive-combination 

; ;  Trans  a  call  to  a  primitive  procedure 
(lambda  (ty  prim  operands  c-t-env) 

((prim-inline-form  prim) 

ty 

(map  (lambda  (a)  (translate  a  c-t-env))  operands)))) 

(define  trans-unknown-combination 

;;  Trans  a  call  to  an  "unknown”  (i.e.  computed)  procedure 
(lambda  (ty  operator  operands  c-t-env) 

(op->icode  ty 

’call 

(cons  (translate  operator  c-t-env) 

(map  (lambda  (a)  (translate  a  c-t-env))  operands))))) 
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C.5  compiler/ exp2ic.fx 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


; ;  new- label  :  symbol  ->  sexpr 

*  I 

(del ins  label-coaster  (rel  0)) 

(deline  reset-label-counter 

(lambda  ()  (:=  label-counter  0))) 

(deline  new-label 
(lambda  (preliz) 

(begin  (:=  label-counter  (  +  (*  label-counter)  1)) 
(string-append  (string-append  preliz  "_•') 

(int->string  (*  label-counter)))))) 


; ;  The  stall  that  lollows  is  all  lor  displaying  intermediate  code 
;;  (lists  ol  labeled  trees)  prettily. 

(deline  unparse-icode 
(lambda  (code) 

(letrec  ((up-ic-list  (lambda  (cl)  (map  unparse-ic  cl)))) 

(match  code 

((labeldel->icode~  lab)  lab) 

((noop->icode-)  ’nop) 

((int->icode"  _  n)  n) 

((string->icode”  a)  (list  ’string-lit  s)) 

((sym->icode*  s)  (list  ’symbol-lit  s)) 

((word->icode"  w)  (list  ’word-lit  w)) 

((labelrel->icode"  _  lab)  lab) 

((reg->icode*  _  re g)  (list  ’r  rag)) 

((op->icode’  _  s  clist)  (cons  s  (map  unparse-icode  clist))) 
((alloc->icode“  _  i  clist)  (list  ’alloc  i  (map  unparse-icode  clist))) 
((var->icode*  _  back  over)  (list  ’var  back  over)) 

( (body->icode"  _  n  b)  ‘(body  (,n)  , (unparse-icode  b))) 
((letrac->icode"  n  1  e) 

‘(letrec  .(map  unparse-icode  1)  .(unparse-icode  e))) 

((retum->icode"  code)  (list  ’return  (unparse-icode  code)  ■'  " 

(deline  display-icode 
(lambda  (code) 

(match  code 

((labeldel->icode~  lab) 

(begin  (newline)  (display  lab)  (display  ”:”))) 

(_  (begin  (display  M  ”)  (pp  (unp^se-icode  code)))  . 
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C  pFX/DLX  COMPILER  IMPLEMENTATION 


C  .5  compiler /exp2ic.fx 

(define  old-display-icode  ; ;  for  list-of-trees-styla  sv 

(lambda  (coda) 

(latrac 

((•p  (lambda  ()  (display  "  "))) 

(print-ic-list  (lambda  (cl) 

(begin 

(display  "(  *•) 

(for-each  (lambda  (a)  (print-icode  a)  (sp))  cl) 
(display  ")")))) 

(priat-icoda 
(lambda  (coda) 

(match  coda 

( (labeldef ~>icode'  lab)  ;  labal  definitions 

(bagia  (display  lab)  (display  '•)  )) 

((noop->icoda*)  ;  ao-op;  ignore  it. 

tha-nait) 

((iat->icoda  _  n)  ;  immediate  iatagers 

(bagia  (display  a))) 

( (string->icode"  s)  ;  immediate  strings 

(bagia  (display  ".string  ••)  (display  s)  )) 

((sym->icode  a)  ;  immediate  symbols 

(bagia  (display  ".symbol  »)  (display  s)  )) 

((vord->icode*  ■) 

(bagia  (display  “.word  ”)  (display  w)  )) 

((labelref->icode*  .  lab)  ;  label  reference 

(begin  (display  lab))) 

((reg->icode*  _  rag)  ;  register  reference 

(begin  (display  "r.")  (display  rag))) 

((op->icoda*  _  a  clist)  ;  operation 

(begin  (display  s)  (sp)  (priat-ic-list  clist))) 

( (alloc->icode”  _  i  clist)  ;  mem  allocation 

(begin  (display  "alloc/")  (display  i)  (print-ic-list  clist))) 
((▼ar->icode*  _  back  over) 

(begin  (display  "var(") 

(display  back)  (display  ",") 

(display  over)  (display  ")"))) 

((body->icode"  _  a  b) 

(begin  (display  "body/")  (display  a) 

(display  "  ")  (print-icode  b))) 

((letrec->icode"  ale) 

(begin  (display  "letrec/")  (display  a) 

(display  "(") 

(for-each  (lambda  (r) 

(begin  (priat-icoda  i)  (display  "  //  -•))) 

;;  the  //  terminates  icode  trees  to  make 
;;  them  more  easily  readable. 

1) 

(display  ")  ") 

(print-icode  e))) 

((retnm->icode*  code) 

(begin  (display  "return  ")  (print-icode  code))))))) 

(match  code 

((labeldef->icode  _)  (print-icode  code))  ;  special  hack  for  indenting 
(_  (begin  (display  "  »)  (print-icode  code))))))) 
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C.6  compiIer/ic2oc.fx 


C  (iFX/DLX  COMPILER  IMPLEMENTATION 


C.6  compiler/ic2oc.fx 


The  contents  of  the  file  compiler/ic2oc.fx: 


;;  Mode:  Schama;  Package:  SCHEME  -*- 

;;;  gen.fx  —  translate  list  of  trass  to  DLX  ocode 

;;  The  coda  generation  is  by  recurs ive-decent  tree  rewriting.  The 
; ;  intermediate  code  tree  is  traversed  depth-first  by  various 
;;  routines.  When  one  of  these  routines  recognizes  the  tree  it  is 
;;  looking  at,  it  emits  code  for  the  tree  and  re-writes  the  tree  into 
;;  another  tree  that  indicates  where  the  result  was  put.  For  example, 

;;  a  (op->icode  tl  ’+  (reg->icode  _  1)  (reg->icode  _  2))  will  be  recognized 

;;  by  the  binary  operation  routine,  which  will  emit  the  code 

;;  "add  r3,  r2,  riM  and  will  rewrite  the  tree  into  (reg->icode  tl  3). 

;;  The  top  level  translation  procedure  is  gencode.  Its  function  is  to 
;;  translate  root  nodes  into  no-ops,  and  to  translate  intermediates 
; ;  and  leaves  into  either  reg->icode  nodes  or  int->icode  nodes  for 
;;  small  integers.  Passing  up  the  small  integers  allows  us  to  take 
;;  advantage  of  operations  w/  special  forms  for  small  immediates.  The 
; ;  various  routines  called  by  gencode  first  translate  the  subtrees  of 
;;  a  node  by  calling  gencode  recursively,  then  translating  the 
;;  simplified  node  through  case  analysis.  Thus  we  use 
;;  recursive-decent  parsing  to  “divide  and  conquer.’’ 

(define  ocode-list  (ref  (null)))  ;  generated  code  will  go  here, 

(define  emit 

(lambda  (op  rands)  (:=  ocode-list  (cons  (insn  op  rands)  (*  ocode-list))))) 
(define  emit-lw 

(lambda  (dst  slot  block)  ;  reg#:int  slot#:int  reg#:int 
(emit  'lw  (load->rands  dst  (otag  slot)  block)))) 

(define  emit-sw 

(lambda  (slot  block  src)  ;  reg#:int  slot#:int  reg#:int 
(emit  ’sw  (store->rands  (otag  slot)  block  src  )))) 

(define  emit-error  ;  for  better  error  reporting  (and  locating!) 

(lambda  (s) 

(begin 

(display  s) 

(newline) 

(emit  'error  (err->rands  s ) ) ) ) ) 
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;;  input  comas  from  icoda-list;  output  goes  to  ocode-list. 

i  » 

(define  generate-ocode 
(lambda  () 

(begin 

(:=  ocode-list  (null)) 

(init-reg-allocator) 

(for-each  (lambda  (x)  (gencoda  x))  (*  icode-list)) 
(:=  ocode-list  (reverse-list  (“  ocode-list)))))) 


Top-level  code  generators  —  translate  any  kind  of  icode  node. 


(define  gencode  ;  (->  (icode)  icode) 

;;  Translate  roots  into  noop->icode;  all  others  into  either 
;;  reg->icode  or  int->icode  (for  small  ints).  In  the  register  case, 

;;  gencode  sill  allocate  a  register,  and  geneode’s  caller  must 
; ;  deallocate  it . 

(lambda  (code) 

(match  code 
((noop->icode") 

((labeldef->icode-  1) 

((body->icode*  ty  num-args  body) 

((letrec->icode*  nvars  vars  body) 

((return->icode*  e) 

((string->icode*  s) 

( (sym->icode'  s) 

( (word->icode*  w) 

((op->icode*  ty  o  1) 

((alloc->icode”  ty  i  codelist) 

((labelref->icode"  ty  1) 

((int->icode*  ty  n) 

((reg->icode"  _  r) 

((var->icode"  ty  back  over) 

(define  full-gencode  ;  (->  (icode)  ico 

; ;  Same  as  gencode  except  no  int->icode  are  returned 
(lambda  (code) 

(let  ((code2  (gencode  code))) 

(match  code2 

((int->icode*  ty  n) 

(let  ((target  (allocate-reg))) 

(begin 

(emit  ’addi  (rri->rands  target  ZERO  (int->string  (itag  n)))) 
(reg->icode  ty  target)))) 

(_  code2) ) ) ) ) 


code) 

(gen-labdef  1)) 

(gen-body  ty  num-args  body)) 
(gen-letrec  nvars  vars  body)) 
(gen-return  e)) 

(gen-string  s)) 

(gen-symbol  s)) 

(gen-word  w)) 

(gen-op  ty  o  1)) 

(gen-alloc  ty  i  codelist)) 

(gen-labref  ty  1)) 

(gen-intref  ty  n)) 
code) 

(gen-varref  ty  back  over))))) 
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(define  target -gencode 

; ;  Sane  as  gencode  except  value  is  stored  into  specified  register 
(lambda  (code  target) 

(let  ((ty  (natch  (gencode  code) 

((reg->icode*  ty  r) 

(if  (=  r  target) 

*7 

(begin  (emit  ’or  (rrr->rands  target  r  ZERO)) 
(deallocate-reg  r) 

ty))) 

((int->icode*  ty  i) 

(begin 

(emit  ’addi  (rri->rands  target  ZERO  (int->string  (itag  i)))) 
ty)) 

(_  unit-type)))) 

(reg->icode  ty  target)))) 


l  » 

i ;  Translation  for.  roots  of  intermediate  code 

l  * 


(define  gen-labdef 

(lambda  (1)  (begin  (emit  ’lateldef  (label->rands  1))  (noop->icode)))) 


(define  gen-string 

(lambda  (s)  (begin  (emit  ’stringdef  (string->rands  s))  (noop->icode)))) 
(define  gen-symbol 

(lambda  (s)  (begin  (emit  ’stringdef  (string->rands  (sym->string  s))) 
(noop->icode)))) 

(define  gen-word 

(lambda  (w)  (begin  (emit  'worddef  (word->rands  s))  •'oop->icode)))) 


(define  gen-return  ;  (->  (icode)  icode) 

;;  Emit  code  to  compute  return  result  into  VAL  register,  then  emit 
; ;  code  to  jump  to  caller  (return  address  taken  from  activation 
;;  frame). 

(lambda  (e) 

(begin 

(target-gencode  e  VAL) 

(emit-lw  ATEMP  2  FP) 

(emit  ’jr  (r->rands  ATEMP)) 

(emit  ’nop  (nop->rands) ) 

(noop->icode)))) 
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;;  Generate  coda  lor  &  lambda  body.  Assumptions:  rag  ARGO  contains 
;;  tbs  addrsss  of  tha  closure  used  to  call  us,  and  rags  ARG1 . . ARGn 

;;  contain  our  params.  The  closure  is  tbe  pair  (codeaddr  environmentptr) . 

(define  gen-body 

(lambda  (ty  num-args  body) 

(let  ((save-args  (map  (lambda  (x)  (reg->icode  unknown-type  x)) 

(integers-between  ARG1  (+  ARGO  num-args)))) 
(stack-env?  (stack-allocate-environment-frame?  (ictype  body)  body))) 
(begin 

;;  Allocate  new  env  frame,  link  into  static  chain  (available  in 
;;  closure  passed  in  ARGO),  and  save  parameter  values  into  it. 
(gen-alloc-block  stack-env?  (+  num-args  1)  EIV)  ;  lew  frame 
(emit-lw  ATEMP  1  ARGO)  ;  Head  of  old  static  chain 

(emit-sw  0  EHV  ATEMP)  ;  link  new  frame  into  static  chain 

(gen-fill-block  EIV  1  save-args)  ;  Sv  args  in  new  env 

(gencode  body))))) 

(define  gen-letrec 

; ;  Same  as  lambda  except  we  fill  the  new  environment  with  evaluations 
;;  of  the  letrec  variables  instead  of  with  argument  registers. 

(lambda  (num-vars  vara  body) 

(let  ((stack-env?  (stack-alloeate-environment-frame?  (ictype  body)  body))) 
(begin 

(gen-alloc-block  stack-env?  (+  num-vars  1)  EHV)  ;  Alloc  env  frame 
(emit-lw  ATEMP  1  ARGO)  ;  Lnk  in2  static  chain 

(emit-sw  0  EIV  ATEMP) 

(gen-fill-block  EIV  1  vars)  ;  Fill  frame  slots  w/  letrec  variables 
(gencode  body))))) 

(define  stack-allocate-environment-frame? 

(lambda  (ty  body)  #f)) 


; ;  Compile  forms  that  call  closures . 

>  t 

(define  gen-call 

;;  Remember  that  first  argument  in  arglist  is  the  closure  to  call. 

(lambda  (ty  arglist) 

(let  ((label  (new-label  "RETURI") ) 

(stack-act?  (stack-allocate-activation-frame?  ty  arglist))) 

(begin 

(gen-begin-activation  ;  Emit  code  to  allocate  and  fill  activation  fiawe 
stack-act?  FrameS ize  label) 

(simulate-stackframe-push)  ;  Since  reg's  are  saved,  we  can  use  them 
(gen- arguments  arglist)  ;  Emit  code  to  compute  arguments 

(emit-lw  ATEMP  0  ARGO)  ;  Get  address  from  closure 

(emit  ’jr  (r->rands  ATEMP)) 

(emit  ’nop  (nop->rands ) ) 

(emit  ’labeldef  (label->rands  label))  ;  Here’s  the  return  label 
(gen-end-activation)  ;  Emit  code  to  restore  registers 

( s imulat  e-st  ackf rame-pop) 


63 


C.  6  compiler /ic2oc.  fx 


C  pFX/DLX  COMPILER  IMPLEMENTATION 


(let  ((result  (allocate-reg)) )  ;  Alloc  a  rag  to  put  result 
(begin  (emit  ’or  (rrr->rands  result  VAL  ZERO)) 
(reg->icode  ty  result))))))) 

(define  stack-allocat e-act ivat ion-frame? 

(lambda  (ty  arglist)  #f)) 

(define  gen- jump 

;;  Generates  a  jump  rather  than  a  call  to  a  closure.  The  first 
;;  argument  in  arg  list  is  the  closure  to  jump  to. 

(lambda  (ty  arglist) 

(begin 

( s imulat e-st ackf r ame-push ) 

(gen-arguments  arglist) 

(emit-1®  ATEMP  0  ARGO) 

(emit  *jr  (r->rands  ATEMP)) 

(emit  ’nop  (nop->rands) ) 

( s imulat  e-stackf r ame-pop ) 

(int->icode  ty  0)))) 

(define  gen-arguments 

;;  compile  args  into  arg  regs.  return  last-used  arg  reg. 

(lambda  (arglist) 

(letrec  ((loop  (lambda  (1  r) 

(if  (null?  1) 
the-unit 

(begin  (allocate-specif ic-reg  r) 
(target-gencode  (car  1)  r) 

(loop  (cdr  1)  (+  r  1))))))) 

(loop  arglist  ARGO)))) 


(define  gen-intref  ;  (->  (int)  icode) 

;;  Small  integer  values  are  are  passed  up.  For  larger  integers,  a 
; ;  register  is  allocated  for  the  int  and  code  is  emitted  to  move  the 
; ;  int  into  the  register . 

(lambda  (ty  n) 

(cond  ;;  ((=  n  0)  (reg->icode  ty  ZERO))  10  VRK  <=  vay  dst  rgs  R  pckd 
((intlfl?  (itag  n))  (int->icode  ty  n)) 

(else  (let  ((target  (allocate-reg) ) 

(tn  (int->string  (itag  n)))) 

(begin 

(if  (and  (>  n  0)  (<  n  32768)) 

(emit  ’addui  (rri->rands  target  ZERO  tn)) 

(begin  (emit  ’lhi  (ri->rands  target  (msw  tn))) 

(emit  ’ori  (rri->rands  target  target  (Is®  tn))))) 
(reg->icode  ty  target))))))) 
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(define  gen-labref  ;  (->  (string)  icode) 

;;  Allocate  reg  and  emit  code  to  move  value  of  label  into  it. 
(laabda  (ty  lab) 

(let  ((target  (allocate-reg))) 

(begin 

(eait  ’lhi  (ri->rands  target  (ass  lab))) 

(eait  ’ori  (rri->rands  target  target  (law  lab))) 
(reg->icode  ty  target))))) 


(define  gen-varref 

(laabda  (ty  back  over) 

(let  ((target  (allocate-reg))) 

(begin  (emit-lw  target  over  (localref  back)) 
(reg->icode  ty  target))))) 


(define  localref  ;  (->  (int)  int) 

; ;  Emits  code  to  walk  up  static  chain.  Returns  register  pointing  to 
;;  frame;  local  variable  can  be  accessed  by  loading  relative  to  this 
;;  pointer. 

(lambda  (back) 

(letrec  ((walk-up  (laabda  (n) 

(if  (=  n  0) 
the-unit 
(begin 

(emit-lw  A TEMP  0  ATEMP) 

(walk-up  (-  n  1))))))) 

(if  (*  back  0) 

ESV 

(begin  (emit-lw  ATEMP  0  ESV) 

(walk-up  (-  back  1)) 

ATEMP))))) 


Translation  for  operators 
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(dal in*  g*n-if 
(lambda  (ty  args) 

(lat  ((treg  (rag-nnm  (lull-gancoda  (car  args)))) 

(con  (car  (cdr  args))) 

(alt  (car  (cdr  (cdr  args)))) 

(alsalabal  (nas-labal  "ELSE")) 

(joinlabal  (nes-label  "JOII"))) 

(begin 

(emit  'beqz  (ri->rands  trag  alsalabal)) 

(emit  ’nop  (nop->rands ) ) 

(deallocate-reg  trag) 

(target-gancoda  con  VAL) 

(emit  ’j  (i->rands  joinlabal)) 

(emit  ’nop  (nop->rands ) ) 

(emit  'labeldaf  (label->rands  alsalabal)) 

(targat-gencode  alt  VAL) 

;;  (emit  ’j  (i->rands  joinlabal))  ;  let  this  case  fall  through... 
;;  (emit  ’nop  (nop->rands)) 

(emit  ’labeldaf  (label->rands  joinlabal)) 

(let  ((result  (allocate-reg)))  ;  Alloc  a  reg  for  result 

(begin  (emit  ’or  (rrr->rands  result  VAL  ZERO)) 

(reg->icode  ty  result))))))) 


(define  gen-begin 

;;  Gen  code  for  a  list  of  expressions,  returning  value  of  last  in 
; ;  list .  Incoming  list  must  have  at  least  one  element . 

(lambda  (ty  codelist) 

(lat  ((result  (gencoda  (car  codelist)))) 

(if  (null?  (cdr  codelist)) 
result 
(begin 

(match  result  ((reg->icode"  _  r)  (deallocate-reg  r))  (_  the-unit)) 
(gen-begin  ty  (cdr  codelist))))))) 


(define  gen-alloc 

; ;  Generate  code  to  allocate  and  fill  a  block  of  memory  vhose  size 
il  i*  fixed  at  compile  time.  Used  for  allocating  cons  cells,  pairs, 

; ;  and  closures . 

(lambda  (ty  size  codelist) 

(let  ((blkptr  (allocate-reg))) 

(begin 

(gen-alloc-block  #f  size  blkptr)  ;  Gen  call  to  blk  alloc 'er 

(gen-fill-block  blkptr  0  codelist)  ;  Fill  blk  w/  values 
(reg->icode  ty  blkptr))))) 


C  uFX/DLX  COMPILER  IMPLEMENTATION _ C.6  compiler/ic2oc.fx 


(define  gea-alloc-block 

;;  Emit  coda  to  call  allocatioa  routiaa,  putting  addraaa  o f 
;;  allocated  block  ia  ragiatar  whoaa  number  ia  paaaed  ia  blkptr. 
(lambda  (atack-alloc?  aiza  blkptr) 

(begin 

(ar it  ’ori  (rri->raada  ATEMP  ZERO  (iat->atriag  (itag  aize)))) 
(if  atack-alloc? 

(emit  ’jal  (i->raada  ".SALLOC")) 

(emit  ’jal  (i->raada  ".ALLOC”))) 

(eait  ’aop  (aop->raada) ) 

(emit  ’or  (rrT->raada  blkptr  ZERO  ATEMP))))) 

(define  gan-i ill-block 

;;  Emit  coda  to  iill  a  block  with  values.  The  values  to  fill  the 
;;  block  with  are  the  raaulta  of  evaluating  codeliat.  The  alots  to 
;;  put  thaae  reaulta  ataxt  at  off aet(blkptr)  aad  go  up  from  there. 

; ;  "offset"  is  slot  aumbar. 

(lambda  (blkptr  offset  codalist) 

(if  (aull?  codelist) 
the-uait 

(let  ((arc  (reg-nnm  (full-geacode  (car  codelist))))) 

(begia 

(emit-aw  offset  blkptr  src) 

(deallocate-reg  arc) 

(gea-f ill-block  blkptr  (+  offset  1)  (cdr  codelist))))))) 


(defiae  gen-begin-activation 

;;  Emit  code  to  allocate  aad  fill  aa  activatioa  frame.  Updates  FP 
;;  register  (aad  SP  if  stack-allocate?  is  true).  Trashes  ATEMP  aad 
; ;  RET ADR. 

(lambda  (stack-allocate?  Faize  return-label) 

(gen-alloc-block  stack-allocate?  Faize  ATEMP) 

(emit-aw  0  ATEMP  FP)  ;  Save  old  frame  pointer 

(emit  'or  (rrr->randa  FP  ZERO  ATEMP))  ;  Load  new  frame  into  FP 

(if  stack-allocate? 

(begia 

(emit  ’addi  (rri->rands  ATEMP  SP  (int->string  (*  4  ( *■  Fsize  1))))) 
(emit-aw  1  FP  ATEMP))  ;  Save  old  value  of  stack  pointer 
(emit-sw  1  FP  SP)) 

(emit  ’lhi  (ri->randa  ATEMP  (maw  return-label))) 

(emit  ’ori  (rri->raads  ATEMP  ATEMP  (law  return-label))) 

(emit-aw  2  FP  ATEMP)  ;  Save  return  address 
(amit-sw  3  FP  ESV)  ;  Save  environment  pointer 
(emit  ’jal  (i->rands  ".SAVE")) 

(emit  ’nop  (nop->rands)) ) ) 
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(define  gen-end-activation 

;;  Sait  coda  to  raatora  registers  saved  in  activation  frame. 
; ;  Trashes  A TEMP  and  RET ADR. 

(lambda  () 

(emit  ’ jal  (i->rands  "^RESTORE")) 

(emit  ’nop  (nop->rands ) ) 

(emit-ln  EHV  3  FP) 

(emit-le  SP  1  FP) 

(emit-lu  FP  0  FP))) 


(define  gen-not 
(lambda  (ty  args) 

(let  ((reg  (reg-nnm  (full-gencode  (car  args))))) 

(begin 

(emit  ’xori  (rri->rands  reg  reg  (int->string  (itag  1)))) 
(reg->icode  ty  reg))))) 


(define  gen-assign  ;  (->  ((listof  icode))  icode) 
(lambda  (ty  args) 

(let  ((areg  (reg-nnm  (full-gencode  (cadr  args)))) 
(dreg  (reg-nnm  (full-gencode  (car  args))))) 
(begin 

(emit-sv  0  dreg  sreg) 

(deallocatc-reg  dreg) 

(deallocata-reg  sreg) 

(int->icode  ty  (itag  0)))))) 
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(define  gen-load  ;  (->  ((listof  icode))  icode) 

>>  The  first  operand  is  a  base  pointer,  i.e.,  a  tagged  pointer  to  a 
>>  block  of  memory  created  by  alloc.  The  second  is  an  integer  index 
;;  pointing  to  a  slot  inside  that  block  of  memory.  Those  slots  are 
;;  numbered  consecutively  0,  1,  2,  ...  The  index  must  be  turned 
;;  into  a  byte  offset,  shich  is  4x  the  index  number,  then  added  into 
;;  the  base,  either  sith  an  explicit  add  or  with  the 
;;  load-eith-displacement  ocode. 

(lambda  (ty  args) 

(let  ((base  (reg-num  (full-gencode  (car  args)))) 

(disp  (gencode  (cadr  args)))) 

(match  disp 

((int->icode"  _  i) 

(begin 

(if  (intl6?  (otag  i)) 

(emit-lv  base  i  base) 

(let  ((dispr  (reg-num  (full-gencode  disp)))) 

(emit  ’slli  (rri->rands  dispr  dispr  "1")) 

(emit  ’add  (rrr->rands  base  base  dispr)) 

(emit-ls  base  0  base) 

(dealloeate-reg  dispr))) 

(reg->icode  ty  base))) 

(_  (let  ((dispr  (reg-num  (full-gencode  disp)))) 

(emit  ’slli  (rri->rands  dispr  dispr  "l  ")) 

(emit  ’add  (rrr->rands  base  base  dispr)) 

(emit-lw  base  0  base) 

(deallocate-reg  dispr) 

(reg->icode  ty  base))))))) 
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(define  gen-vec-alloc 

; ;  Generate  code  to  allocate  and  fill  a  block  of  memory  where  both  the 
;;  size  and  the  contents  of  the  block  are  computed  at  compile  time,  ill 
;;  slots  of  the  block  are  filled  with  the  same  value.  Used  for  allocating 
; ;  vectors . 

(lambda  (ty  codelist) 

(let*  ((blkptr  (allocate-reg) ) 

(size  (reg-num  (full-gencode  (car  codelist)))) 

(filler  (reg-num  (full-gencode  (cadr  codelist)))) 

(loop  (new-label  “LOOP")) 

(test  (new-label  "TEST"))) 

(begin 

(emit  ’or  (rrr->rands  ATEMP  ZERO  size)) 

(emit  ’jal  (i->rands  ".ALLOC")) 

(emit  ’nop  (nop->rands)) 

(emit  ’or  (rrr->rands  blkptr  ZERO  ATEMP)) 

(emit  ’j  (i->rands  test)) 

(emit  ’nop  (nop->rands) ) 

(emit  'labeldef  (label->rands  loop)) 

(emit-sw  0  ATEMP  filler) 

(emit  ’addi  (rri->rands  ATEMP  ATEMP  (int->string  4))) 

(emit  ’labeldef  (label->rands  test)) 

(emit  ’subi  (rri->rands  size  size  (int->string  2))) 

(emit  ’bnez  (ri->rands  size  loop)) 

(emit  ’nop  (nop->rands) ) 

(deallocate-reg  size) 

(deallocate-reg  filler) 

(reg->icode  ty  blkptr))))) 


(define  gen-vec-length 
(lambda  (ty  codelist) 

(let  ((vec  (reg-num  (full-gencode  (car  codelist))))) 
(begin 

(emit-lw  vec  -1  vec) 

(reg->icode  ty  vec))))) 
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(deline  gen-vec-set! 

(lambda  (ty  codalist) 

(l«t*  ( (vac  (reg-nua  (lull-gencoda  (car  codelist)))) 

(idx  (gencode  (cadr  codelist))) 

(val  (reg-num  (lull-gencoda  (cadr  (cdr  codelist)))))) 
(begin 

(match  idx 

((int->icode*  _  i) 

(il  (intl6?  (otag  i)) 

(emit-ss  i  vec  val) 

(let  ((dispr  (reg-nna  (lull-gencoda  idx)))) 

(begin 

(emit  ’slli  (rri->rands  dispr  dispr  “l")) 
(emit  ’add  (rrr->rands  vac  vec  dispr)) 
(emit-sw  0  vec  val) 

(deallocate-reg  dispr))))) 

((reg->icode“  _  dispr) 

(begin 

(emit  ’slli  (rri->rands  dispr  dispr  "1”)) 

(emit  ’add  (rrr->rands  vec  vac  dispr)) 

(emit-sw  0  vec  val) 

(deallocate-reg  dispr)))) 

(deallocate-reg  v?.l) 

(deallocate-reg  vac) 

(int->icode  ty  0))))) 


(deline  gen-sym2string 
(lambda  (ty  codelist) 

(let  ((sym  (reg-nua  (lull-gencoda  (car  codelist))))) 
(begin 

(emit  ’or  (rrx-> rands  ATEMP  sym  ZERO)) 

(emit  ’ jal  (i->rands  ".SYHZSTRIIG’’) ) 

(emit  ’nop  (nop->rands ) ) 

(emit  'or  (rrr->rands  sym  ATEMP  ZERO)) 
(reg->icode  ty  sym))))) 


(deline  gen-put-char 
(lambda  (ty  codelist) 

(begin 

(target-gencode  (car  codelist)  ATEMP) 

(emit  'jal  (i->rands  ".TPUTCHAR") )  ;  arg  is  tagged,  so  use  tagged  vers, 
(emit  ’nop  (nop->rands) ) 

(int->icode  ty  0)))) 
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(define  gen-op  ;  (->  (op  (listof  icode))  icode) 

; ;  The  coda  generators  lor  each  type  ol  oparator  axe  kept  in  a  table 
;;  indexed  by  tha  operation  symbol,  is  mentioned  before,  code 
;;  generation  is  by  recursive  decent:  se  translate  sub-trees  first  by 
;;  calling  gencode,  then  translate  the  operator. 

(lambda  (ty  op  args)  ((op-table  op)  ty  args))) 

(define  make-binop-gen 

;;  Code  generators  for  alu  binary  op's  all  look  the  same,  so  abstract, 
(lambda  (op  opi) 

(lambda  (ty  args) 

(let  ((1  (reg-num  (full-gencode  (car  args)))) 

(r  (gencode  (cadr  args)))) 

(begin 
(match  r 

((int->icode"  _  n) 

(emit  opi  (rri->rands  1  1  (int->string  (itag  n))))) 
((reg->icode"  _  rxeg) 

; ;  Do  the  general  thing 

(begin  (emit  op  (rrr->rands  1  1  rreg)) 

(deallocate-reg  rreg)))) 

(reg->icode  ty  1)))))) 


(define  make-binop-gen2 

; ;  Binary  operators  */  no  built-in  ALU  operation 
(lambda  (emitter) 

(lambda  (ty  args) 

(let  ((1  (reg-num  (full-gencode  (car  args)))) 

(r  (reg-num  (full-gencode  (cadr  args))))) 
(begin  (emitter  1  r) 

(deallocate-reg  r) 

(reg->icode  ty  1)))))) 

(define  emit-mul 
(lambda  (1  r) 

(begin  (emit  ’movi2fp  (rr->rands  FPO  1)) 

(emit  ’srai  (rri->rands  ATEMP  r  "i")) 

(emit  *movi2fp  (rr->rands  FP1  ATEHP)) 

(emit  ’mult  (rrr->rands  FP 2  FPO  FP1)) 

(emit  *movfp2i  (rr->rands  1  FP2))))) 

(define  emit-div 
(lambda  (1  r) 

(begin  (emit  ’movi2fp  (rr->rands  FPO  D) 

(emit  ’movi2fp  (rr->rands  FP1  r)) 

(emit  ’div  (rrr->rands  FP2  FPO  FP1)) 

(emit  *movfp2i  (rr->rands  1  FP2)) 

(emit  ’slli  (rri->rands  1  1  "1”))))) 
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(define  •ait-remainder 
(lambda  (1  r) 

(begin  (emit  ’aovi2fp  (rr->rands  FPO  1)) 
(emit  ’movi2fp  (xr->randa  FP1  r)) 
(emit  'div  (rrr->randa  FP2  FPO  FP1)) 
(•ait  'mult  (rrr->randa  FP3  FP2  FP1)) 
(emit  ’movfp2i  (rr->randa  ATEMP  FP3)) 
(•ait  ’sub  (rrr- >rands  1  1  ATEMP))))) 


(define  op-table 

(let  ((empty  (lambda  (bad-op) 

(emit-error  (atring-append  "bad  op:  "  (sym->string  key))))) 

(op-liat 

’((+  , (make-binop-gen  ’add  ’addi)) 

(-  , (make-binop-gen  ’sub  'anbi)) 

(seq  .(make-binop-gen  ’aeq  ’aeqi)) 

(alt  , (make-binop-gen  ’alt  ’alti)) 

(ale  .(make-binop-gen  ’ale  ’alei)) 

(agt  .(make-binop-gen  ’agt  ’agti)) 

(age  , (make-binop-gen  ’age  ’agei)) 

(*  . (make-binop-gen2  emit-mul) ) 

(/  , (aake-binop-gen2  emit-div) ) 

(remainder  , (make-binop-g«n2  emit-reaiainder) ) 

(:=  .gen-aaaign) 

(*  .gen-load) 

(vec-alloc  ,gen-vec-alloc) 

(vec-set  .gen-vec-aet ! ) 

(vec-length  ,gen-vec-length) 

(sym2atring  ,gen-aym2atring) 

(put -char  , gen-put-char) 

(not  ,gen-not) 

(call  , gen-call) 

(jump  .gen- jump) 

(if  .gen- if) 

(begin  ,gen-begin)))) 

(list2env  empty  aym=?  op-liat))) 


; ;  Tags : 

; ;  The  leaat  aignif icant  bit  of  each  machine  uord  ia  uaed  aa  a  tag  ao  that 

;;  the  garbage  collector  can  diatinguiah  pointera  from  integers.  All 

;;  integer  valuea  are  shifted  up  one  bit  position  (i.e.,  multiplied  by 
;;  two)  to  have  a  zero  tag.  Pointera  (which  all  point  to  things  on  word 

;;  boundaries,  and  so  are  all  multiples  of  four)  are  given  a  tag  of  1.  To 

; ;  dereference  a  pointer,  one  must  subtract  one  from  it  before  indirecting 

; ;  through  it . 

(define  itag  (lambda  (i)  (•  2  i)))  ;  tag  an  integer 

(define  de-itag  (lambda  (i)  (quotient  i  2))) 
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(define  otag 

;;  For  referencing  into  object  slots.  Takas  a  slot  number  and 
;;  ratnms  an  offset  which,  whan  addad  to  a  pointar,  addresses  tha 
;;  desired  data  value.  (Remember  slot  -1,  tha  size  of  tha  object, 
;;  is  stored  at  address  “tagged  pointer  -  1,"  slot  0  at 
;;  "tagged_po inter  +  3,“  ate.) 

(lambda  (slot)  (+  (*  slot  4)  3))) 

(define  de-otag  (lambda  (i)  (/  (-  i  3)  4))) 

(define  intlS?  ;  (->  (int)  bool) 

(lambda  (a)  (and  (<=  n  32787)  (>=  n  -32768)))) 

(define  msw 
(lambda  (1) 

(string-append  "(("  (string-append  1  ")»18)lt0x0000ffff “) ) ) ) 
(define  lsw 

(lambda  (1)  (string-append  “("  (string-append  1  “)*Oxffff ")))) 


(define  FrameSize  28) 

; ;  Symbolic  names  for  some  registers  (local  to  this  file  with  one 
; ;  exception  noted  below) . 


(define 

ZERO 

0) 

(define 

VAL 

1) 

(define 

EIV 

2) 

(define 

FP 

3) 

(define 

SP 

4) 

(define 

HP 

5) 

(define 

ARGO 

6) 

(define 

ARG1 

7) 

(define 

ARG2 

8) 

(define 

ARG3 

9) 

(define 

ARG4 

10) 

(define 

ARG6 

11) 

(define 

ARG6 

12) 

(define 

ARG7 

13) 

(define 

ARG8 

14) 

(define 

ARG9 

15) 

(define 

TOPARG 

29) 

(define 

ATEMP 

30) 

(define 

RET ADR 

31) 

(define 

FPO  0) 

(define 

FP1  1) 

(define 

FP2  2) 

(define 

FP3  3) 

(define 

FP4  4) 

(define 

FP6  5) 

;  this  def  is  nsed  in  exp2ic.fx 
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Register  allocation 


;;  The  following  def’s  ara  local  to  the  allocator 

(dafina  *frae-regs*  (raf  (genarate-vactor  0  (lambda  (i)  #t)))) 

(dafina  *free-reg-stack*  (raf  ’())) 

(dafina  *num-allocatable*  (+  1  (-  TOPARG  ARGO))) 

(dafina  allocatabla-rag?  (lambda  (r)  (and  (<=  ARGO  r)  (<=  r  TOPARG)))) 

(dafina  rag-fraa? 

(lambda  (r)  (and  (allocatabla-rag?  r) 

(vactor-raf  (*  afree-regs*)  (-  r  ARGO))))) 

(dafina  taka-rag!  (lambda  (r)  (vector-sat!  (*  *free-regs*)  (-  r  ARGO)  #f))) 
(dafina  put-rag!  (lambda  (r)  (vectoi-aat !  (*  afree-regs*)  (-  r  ARGO)  #t))) 

; ;  Tha  following  daf's  ara  exported  by  tha  allocator,  but  ara  local  to 
; ;  this  file. 

(dafina  init-reg-allocator 
(lambda  () 

(begin 

(:»  *frea-rag-atacka  ’()) 

(:=  afraa-ragsa  (genarata-vactor  *num-allocatablea  (lambda  (i)  #t)))))) 

(dafina  allocate-T«g 
(lambda  () 

(latrac  ((loop  (lambda  (r)  (cond  ((>  r  TOPARG)  (error  "Out  of  registers.")) 

((rag-fraa?  r)  (begin  (taka-rag!  r)  r)) 
(else  (loop  (+  r  1))))))) 

(loop  ARGO)))) 

(dafina  allocate-specif ic-reg 
(lambda  (r) 

(if  (rag-fraa?  r) 

(begin  (take-rag!  r)  r) 

(error  "Register  needed  twice.")))) 

(dafina  deallocate-reg 
(lambda  (rag) 

(if  (allocatabla-rag?  rag) 

(put-rag!  rag) 
the-unit))) 

(dafina  highest-used-reg 
(lambda  () 

(latrac  ((loop  (lambda  (r)  (cond  ((<  r  ARGO)  ARGO) 

((not  (rag-free?  r))  r) 

(else  (loop  (-  r  i))))))) 

(loop  TOPARG)))) 
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(define  simulate-stackframe-push 
(lambda  () 

(begin 

(:*  *frea-reg-stack*  (cona  (*  *free-regs*)  (*  *free-reg-stack*) ) ) 

(:-  *free-regs*  (generate- vector  *num-allocatable*  (lambda  (i)  #t)))))) 

(deiina  simulate-stackframe-pop 
(lambda  () 

(bagla 

(:=  *free-regs*  (car  (*  *free-reg-stack*))) 

(:=  *free-reg-stack*  (cdr  (*  *free-reg-stack*)))))) 


C.7  compiler/ icode.  fx 

The  contents  of  the  file  compiler/icode.fx: 


; ;  -*-  Noda:  Schama;  Packaga:  SCHEME  -*- 


(dof ina-datatypa  icoda 
; ;  traa  roota: 


(labeldef->icode  string) 

(body->icoda  typa  int  icoda) 
(letrec->icode  int  (liatof  icoda)  icoda) 
(noop->icode) 

(atring-> icoda  string) 

(aym->icoda  aym) 


labal  definitions 
atack-act  atack-env 
num-vars  vara  body 
no-op 

immediate  at rings 
immadiata  symbols 


; ;  intarmadiata  nodaa 


(retum->icode  icoda) 

(op->icoda  typa  aym  (liatof  icoda)) 
(alloc->icoda  typa  int  (listof  icoda)) 


;  return  an  a;  •• 
;  primitive  operations 
;  mem  allocation 


; ;  leaf  nodes 


(labelref->icode  typa  atring) 
(int-> icoda  typa  int) 
(reg->icode  type  int) 
(var->icode  type  int  int) 
(word->icode  string)) 


refs  to  labels 
immediate  integers 
register  ref  (for  codegen...) 
var  refs  (back,  over) 

For  labels  used  aa  ints.  This 
node  can  also  *  :•  ■  >t. ' 


(define  noop  (noop->icode) )  ;  only  need  one  of  these... 


(define  reg-num  ;  quick  access  to  register  numbers 
(lambda  (icode)  (match  icode  ((reg->icode*  _  n)  n)))) 
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C.8  compiler/ lib.  fx 


(define  ictype 

;;  Find  the  high-level  type  associated  with  a  piece  of  icode.  lote  that 
;;  this  operation  is  not  appropriate  for  all  icodes.  For  example,  there 
;;  is  no  type  associated  with  labeldef-> icode.  The  only  root  with  a 
;;  type  slot  is  the  body  slot:  this  type  does  not  give  the  type  of  the 
;;  expression,  but  rather  is  just  a  say  to  communicate  dosn  the  types 
;;  of  the  arguments.  return->icode  does  not  have  a  type  slot  because 
; ;  the  type  of  that  expression  is  just  the  type  of  the  value  being  returned. 
; ;  sord->icode  does  not  have  a  type  slot  because  it  is  used  for  internal 
; ;  compiler  stuff . 

(lambda  (ic) 

(match  ic 

( (body->icode*  ty  _  _)  ty) 

((letrec->icode"  _  _  ic)  (ictype  ic)) 

((retum->icode*  ic)  (ictype  ic)) 

((op->icode*  ty  _  _)  ty) 

((alloc->icode*  ty  _  _)  ty) 

((labelref->icode"  ty  _)  ty) 

((int->icode"  ty  _)  ty) 

((reg->icode"  ty  _)  ty) 

((var->icode*  ty  _  _)  ty)))) 


C.8  compiler /lib.fx 

The  contents  of  the  file  compiler /lib.fx: 

; ;  -*-  Mode :  Scheme ;  Package :  SCHEME  -*- 

;;  lib.fx  —  compile-time  environments  and  built-ins 

; ;  This  file  contains  the  compile-time  environments  and  built-in 
;;  primitives  for  mico-FX  built-ins.  There  are  two  compile  time 
;;  environments,  one  for  the  type  reconstructor  (standard-type-env) 

;;  and  another  for  the  exp2ic  translator  (standard-c-t-env) .  This 
;;  file  exports  the  following  variables: 

;;  lib-init:(->  ()  unit) 

;;  Initializes  stuff  internal  to  library;  needs  to  be  called  once 
;;  per  compilation. 

; ;  c-t-lookup: (->  (c-t-env  sym)  binding) 

; ;  Returns  the  binding  for  sym;  aborts  with  error  if  not  found. 

;;  c-t-bind: (->  ((listof  sym)  c-t-env)  c-t-env) 

; ;  Returns  new  environment  with  a  new  lexical  level  containing 
; ;  the  list  of  symbols  pushed  onto  the  old  environment. 

;;  standard-c-t-env: c-t-env 

;;  Standard  environment  defined  by  microFX  (containing  bindings 
; ;  for  +  ,  -,  etc. ) . 

»  » 

;;  The  c-t-env  abstract  type  is  defined  by  operations  in  this  file.  The 
; ;  environment  itself  is  an  abstract  type  defined  by  two  operations: 
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; ;  (define-datatype  binding 
; ;  (back+over->binding  int  int ) 

; ;  (primitive->binding  prim) ) 

i  # 

; ;  The  "binding"  data  type  ia  raturnad  by  c-t-lookup.  back+ovar  is 
;;  lor  variables  defined  by  tba  coda  baing  compiled:  back  indicates 
; ;  bos  lax  down  tba  static  chain  tba  variable  resides  (0  ==> 

;;  variable  is  in  currant  environment),  over  indicates  bow  far  over 
; ;  in  tbe  environment  frame  tba  variable  resides . 

i  « 

; ;  "prim"  is  an  abstract  data  type  used  lor  variables  defined  by 
;;  microFX.  It  bas  tba  operations: 

»  I 

;;  prim-constant?: (->  (prim)  bool) 

;;  Returns  true  ill  primitive  is  a  constant  (eg,  tbe-unit) 

;;  ratber  than  a  function  (eg,  +) . 

;;  prim- inline-1 orm: (->  (prim)  (->  ((listof  icode))  icode)) 

;;  For  functional  primitives,  returns  a  function  that  takes  a 
; ;  list  of  icode  which  are  tbe  arguments  to  tbe  function  and 

;;  returns  icode  that  computes  tbe  function  on  those  arguments. 

;;  prim-closure-form: (->  (prim)  icode) 

;;  For  functional  primitives,  returns  icode  which  is  a  closure 
;;  for  tbe  indicated  primitive. 

I  » 

; ;  Iota  that  prim-inline-form  and  prim-closure-form  can  modify  tbe 
; ;  library-icode  list ,  a  list  of  auxilary  icode  needed  by  library 
; ;  functions . 

(define  lib-init 

(lambda  ()  (:»  prim-closure-env  (mk-empty-env  add-prim-closure)))) 

(del ine-datatype  prim 

; ;  Tbe  following  data  structure  is  used  inside  this  module  to  hold 
;;  important  data  about  tbe  built-ins  in  tbe  library.  For  built-ins 
;;  coded  in  assembly  language,  tbe  structure  bolds  the  label  of  tbe 
;;  routine.  For  library  routines  coded  in  micro-FX,  the  structure 
;;  contains  tbe  unparsed  micro-FX  ezpresssion  for  the  routine.  For 
;;  library  routines  that  can  be  inlined  (e.g.,  +  ,  -  *),  tbe 
; ;  structure  bolds  both  an  unparsed  ezpresssion  for  tbe  routine  plus 
; ;  a  procedure  that  takes  a  list  of  arguments  (in  icode  form)  and 
;;  returns  icode  for  tbe  inlined  procedure.  Tbe  first  is  used  in 
;;  situations  like  ’+,  while  tbe  second  is  used  in  situations  like  (+  x  y). 
(asa->prim  ty  label)  ;  prim  coded  in  assy  lang  (in  "microFX/runtime) 

(cnst->prim  icode)  ;  prim  is  a  constant 

(lib->prim  sexp)  ;  prim  coded  in  microFX 

(inline->prim  sexp  (->  ((listof  icode))  icode)))  ;  inline-able  prim 
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(define-datatype  binding 

;;  Bindings  held  in  th«  compile-time  environment.  Primitives  are 
;;  wrapped  np  as  uniqueof’s  so  we  can  have  a  table  of  them  (using  eq?). 
;;  (The  type  (oniqneof  t)  denotes  the  set  of  values  for  which  each 
;;  element  of  type  is  distinguishable.  In  other  words,  it’s  a  promise 
;;  to  the  compiler  that  there’s  no  sharing  of  elements,  so  eq?  will 
;;  works.  The  current  minifx  interpreter  doesn't  actually  do  anything 
;;  with  this  information,  but  there’s  always  tomorrow...) 

»  t 

(primitive->binding  (uniqueof  prim)) 

(back+over->binding  int  int)) 


;;  Code  implementing  c-t-env  used  by  exp2ic.  Ve  don’t  use  our 
; ;  usual  environments  here  so  we  can  encode  back+over  in  the 
;;  lambda’s  that  make  up  the  environment. 

(define  empty- c-t-env  (lambda  (var)  (error  "unbound  variable"  var))) 

(define  c-t-lookup  (lambda  (c-t-env  var)  (c-t-env  var))) 

(define  c-t-add-prims 
(lambda  (ops  prims  env) 

(letrec  ((loop  (lambda  (var  ops  prims) 

(if  (null?  ops) 

(env  var) 

(if  (same-variable?  (car  ops)  var) 
(primitive->binding  (car  prims)) 

(loop  var  (cdr  ops)  (cdr  prims))))))) 
(lambda  (var)  (loop  var  ops  prims))))) 

(define  c-t-bind 

(lambda  (formals  c-t-env) 

(lambda  (var) 

(letrec  ((loop  (lambda  (i  formals) 

(if  (null?  formals) 

(match  (c-t-lookup  c-t-env  var) 
((back+over->binding"  back  over) 
(back+over->binding  (+  back  1)  over)) 
(binding  binding)) 

(if  (same-variable?  var  (car  formals)) 
(back+over->binding  0  i) 

(loop  (+  i  I)  (cdr  formals))))))) 

(loop  1  formals))))) 

(define  prim-constant? 

(lambda  (prim) 

(match  (value  prim) 

((cnst->prim*  ic)  #t) 

(.  «)))) 

(define  prim-constant-form  ;;  (->  (prim)  icode) 

(lambda  (prim) 

(match  (value  prim) 

((cnst->prim*  ic)  ic)))) 
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(define  prim-inline-form  ;;  (->  (prim)  (->  (ty  (listof  icode))  icode)) 

(l>mbda  (prim) 

(match  (value  prim) 

((inline->prim*  _  emitter)  emitter) 

(_  (lambda  (ty  arga) 

(op->icode  ty  'call  (cona  (prim-closure-form  prim)  arga))))))) 

(define  prim-cloaure-form  ; ;  (->  (prim)  icode) 

(lambda  (prim)  (("  prim-closure-env)  prim))) 

; ;  Closures  for  library  routines  are  created  only  once  and  are 
;;  memo iz ad  in  prim-closure-env,  defined  below. 

(define  add-prim-closure 

; ;  If  primitive  not  already  in  the  environment ,  then  make  a  closure 
; ;  icode  for  it  and  insert  that  icode  into  the  table 
(lambda  (prim) 

(begin  (enter-library)  ;;  Trans  lib  fn’s  w/  separate  delay  list 
(let  ((closure  (make-prim-closure  prim))) 

(begin  ( : =  prim-closure-env 

((mk-binder  eq?)  prim  closure  (“  prim-cloaure-env))) 
(leave-library)  ; ;  Back  to  normal 
closure))))) 

(define  prim-closure-env  (ref  (mk-empty-env  add-prim-closure))) 

(define  make-prim-closure 

;;  There's  no  closure  for  this  prim  yet  (first-time  reference).  Make  one. 
(lambda  (prim) 

(match  (value  prim) 

( (aam->prim*  ty  label)  ;  asm  prim:  grab  closure, 

(trans-closure  ty  label)) 

( ( ialine->pr im~  sexp  _)  ;  inline  prim:  create  and  compile  one. 

(lets  ((exp  (parse  sexp)) 

(type  (reconstruct-top  exp))) 

(translate  exp  standard-c-t-env)) ) 

((lib->prim"  sexp)  ;  same  for  lib  prims. 

(let*  ((exp  (parse  sexp)) 

(type  (reconstruct-top  exp))) 

(translate  exp  standard-c-t-env)))))) 

; ;  Functions  to  create  icode  for  inlined  primitive  operations 

(define  mk-op-prim  ; ;  +  -  *  quotient  . . . 

(lambda  (op)  (lambda  (ty  arglist)  (op->icode  ty  op  arglist)))) 

(define  mk-cons-prim  ;;  Data  constructor:  cons,  p  1 :,  ref 
(lambda  (size) 

(lambda  (ty  arglist)  (alloc->icode  ty  size  arglist)))) 
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C.8  compiler/  lib,  fx 


(define  mk-sel-prim 

;;  Projection  functions:  car,  cdr,  left,  right,  etc. 

;;  Tagging  implements  a  check  for  (car  (null))  or  (cdr  (null))  ! 
(lambda  (offset) 

(lambda  (ty  arglist) 

(op->icode  ty  *“  (list  (car  arglist) 

'int->icode  integer-type  offset)))))) 

(define  assign-prim  For  := 

(lambda  (ty  arglist)  (op->icode  ty  ’:  =  arglist))) 


(define  neg-prim 

(lambda  (ty  arglist)  (op->icode  ty  ’sub  (cons  (int->icode  ty  0)  arglist)))) 
(define  null-prim 

;;  The  empty  list  is  represented  as  immediate  0.  It’s  untagged  so 
;;  the  garbage  collector  doesn’t  try  to  folios  it. 

(lambda  (ty  arglist)  (int->icode  ty  0))) 


(define  null?-prim 
(lambda  (ty  arglist) 

(op->icode  ty  'aeq  (list  (car  arglist)  (int->icode  integer-type  0))))) 
(define  sym->string-prim 

(lambda  (ty  arglist)  (op->icode  ty  ’sym2string  arglist))) 

(define  cvt-prim  ; ;  Pass  argument  straight  thru  —  for  type  coersion 
(lambda  (ty  arglist)  (car  arglist))) 

(define  put-char-prim 

(lambda  (ty  arglist)  (op->icode  ty  'put-char  arglist))) 

(define  void-prim 

;;  Cons  up  a  fake  argument.  In  real  life,  this  routine  should  generate 
; ;  code  to  crash  the  system. 

(lambda  (ty  arglist)  (int->icode  ty  0))) 

(define  void-name 

; ;  Hake  it  hard  for  the  user  to  get  at  the  void  function 
(string->symbol  "the  void  function")) 


(define  no-prim 

(lambda  (ty  arglist)  (eiror  "Unimplemented  primitive  used.”))) 


;  Most  built  in  functions  are  written  in  micro-FX  code.  This  code  is 
;  listed  below.  These  expressions  are  evaluated  in  the  standard 
;  compile  time  environment,  built-ins  can  call  one  smother. 


; ;  Char  prims 
(define  mk-char-ci-pred 

(lambda  (op)  ‘(lambda  (x  y)  (,op  (char-downcase  x)  (char-downcase  y))))) 
(define  1-char-alphabetic? 

’(lambda  (x)  (or  (chsm-lower-case?  x)  (chsir-upper-case?  x ) ) ) ) 
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(del in*  1-char-numeric? 

’ (lambda  (z) 

(and  (>=  (char->int  z)  (char->int  #\0)) 

(<=  (char->int  z)  (char->int  #\0))))) 

(define  1-char-whitespace? 

’(lambda  (z) 

(or  (=  (char->int  z)  (char->int  space)) 

(=  (char->int  z)  (char->int  tab)) 

(=  (char->int  z)  (char->int  page)) 

(=  (char->int  z)  (cbar->int  newline))))) 

(define  1-char-lower-case? 

’ (lambda  (z) 

(and  (>=  (char->int  z)  (chax->int  #\a)) 

(<=  (char->int  z)  (char->int  #\z))))) 

(define  l-char-upper-case? 

’ (lambda  (z) 

(and  (>=  (cbar->int  z)  (char->int  #\A)) 

(<=  (char->int  z)  (char->int  #\Z))))) 

(define  1-char-upcase 
’ (lambda  (z) 

(if  ( char-lower-case?  z) 

(int->char  (♦  (char->int  #\A)  (-  (char->int  z)  (char->int  #\a)))) 
z))) 

(define  1-char-downc* 

’(lambda  (z) 

(if  (char-upper-case?  z) 

(int->char  (+  (char->int  #\a)  (-  (char->int  z)  (char->int  #\A)))) 
z))) 

; ;  List  prims 

; ;  (define  1-set-car! 

; ;  (define  1-set-cdr! 

(define  1-length 
’(lambda  (1) 

(letrec  ((loop  (lambda  (1st  len) 

(if  (null?  1st)  len  (loop  (cdr  1st)  (+  len  1)))))) 

(loop  1  0)))) 

; ;  (define  1-append 

(define  1-reverse  ;  minifz  doesn’t  have  this  built-in. 

’(lambda  (1) 

(letrec  ((loop  (lambda  (1st  rev) 

(if  (null?  1st) 

rev 

(loop  (cdr  Is  (cons  (car  1st)  rev)))))) 

(loop  1  (null))))) 
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; ;  (define  1-list-tail 
; ;  (define  1-list-ref 
; ;  (define  1-nap 
; ;  (define  1-for-each 
; ;  (define  1-rednce 

(define  l-list->string  ’(lambda  (1)  (vector->string  (liat->vector  1)))) 
(define  l-string->list  ’(lambda  (s)  (vector->list  (string->vector  s)))) 

; ;  Strings 

;;  (define  1-string-fill! 

; ;  (define  l-string=? 

; ;  (define  l-string<? 

; ;  (define  l-string>? 

; ;  (define  l-string<=? 

; ;  (define  l-string>=? 

; ;  (define  l-string-ci=? 

; ;  (define  l-string-ci<? 

; ;  (define  l-string-ci>? 

; ;  (define  l-string-ci<=? 

; ;  (define  l-string-ci>=? 

; ;  (define  1-substring 
(define  1-string-append 
’(lambda  (si  s2) 

(letrec  ((r  (make-string  (+  (string-length  si)  (string-length  s2))  #\X)) 
(loop  (lambda  (s  i  j) 

(if  (>=  i  (string-length  s)) 
the-unit 
(begin 

(string-set!  r  j  (string-ref  s  i)) 

(loop  s  (+  i  1)  (+  j  1))))))) 

(begin  (loop  si  0  0)  (loop  s2  0  (string-length  si))  r)))) 

! ;  (define  1-string-copy 

; ;  Syms 

; ;  (define  l-sym-> string 
; ;  (define  l-string->sym 
; ;  (define  l-sym=? 

; ;  (define  1-hash 

; ;  Vectors 

(define  1-make-vector  (mk-op-prim  ’vec-alloc)) 

(define  1-vector-length  (mk-op-prim  ’vec-length) ) 

(define  1-vector-ref  (mk-op-prim  ’*)) 

(define  1— vector— set !  (mk-op— prim  ’vec-set)) 

;;  (define  1-vector-fill! 

(define  l-vector->list 
’(letrec  ((v21  (lambda  (v  i  1) 

(if  (=  i  -1) 

1 

(v21  v  (-  i  i)  (cons  (vector-ref  v  i)  1)))))) 

(lambda  (v)  (v21  v  (-  (vector-length  v)  1)  (null))))) 
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(define  l-list->vector 

‘(letrec  ((12v  (lambda  (1  i  v) 

(if  (=  i  (vector-length  v)) 
v 


(begin  (vector-set!  v  i  (car  1)) 

(12v  (cdr  1)  (+  i  1)  v)))))) 

(lambda  (1) 

(ii  (=  (length  1)  0) 

(make-vector  (length  1)  (.void-name)) 

(12v  1  0  (make-vector  (length  1)  (car  1))))))) 


(define  1-vector-map 
(define  l-vector-map2 
(define  1-vector-reduce 
(define  1-scan 
(define  1-segmented-scan 
(define  l-compress 
(define  1-exp and 
(define  1-eoshift 


; ;  Unparsers 

(define  1-nnparse-bool  '(lambda  (x)  (if  x  "#t"  "#f"))) 

(define  1-nnparse-char  ’(lambda  (x)  (string-append  "#\\"  (make-string  1  x)))) 
(define  1-unparse-nnit  ’(lambda  (x)  ,,#n”)) 


(define  1-unparse-int 
’(lambda  (x) 

(letrec  ((loop  (lambda  (1  i) 

(if  (.-  i  0) 

(vector->string  (list->vector  1)) 

(loop  (cons  (int->char 

(+  (remainder  i  10)  (chax->int  #\0))) 
1) 

(/  i  10)))))) 


(if  (=  x  0) 


"0" 


(if  (<  x  0) 

(string-append  (loop  (null)  x)) 
(loop  (null)  x)))))) 


(define  1-unparse-string 

’(lambda  (x)  (string-append  ”\MM  (string-append  x  "V”)))) 

(define  1-unparse-symbol 

’(lambda  (x)  (string-append  "(symbol  "  (string-append  (sym->string  x)  ")")))) 
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(define  1-unparse-list 
'(lambda  (pr  x) 

(letrec  ((loop 

(lambda  (a  x) 

(ii  (null?  x) 

(string-append  s  ")") 

(loop  (string-append  s  (string-append  "  "  (pr  (car  x)))) 
(cdr  x)))))) 

(loop  "(list"  x)))) 

(deline  1-unparse-vector 
’ (lambda  (pr  x) 

(string-append  "(list->vector  “ 

(string-append  (unparse-list  pr  (vector->list  x))  ")")))) 

(deline  1-unparse-pair 
’ (lambda  (prl  prr  x) 

(string-append 
"(pair  " 

(string-append  (prl  (lelt  x))  (string-append  (prr  (right  x))  ")"))))) 

(deline  1-put-string 
’ (lambda  (s) 

(letrec  ((loop 

(lambda  (i) 

(it  (>=  i  (string-length  s)) 
the-unit 

(begin  (put-char  (string-rel  si))  (loop  (+  i  1))))))) 

(loop  0)))) 

; ;  The  list  "standard-prim-bindings"  contains  typing  and  other 
;;  information  about  micro-lx  built-ins.  This  list  is  used  to 
;;  initialize  two  other  lists,  the  standard  type  environment  used  by 
; ;  the  type  checker  and  the  standard  compile-time  environment  used  by 
;;  the  expression  to  icode  translator. 

;;  Each  entry  ol  the  list  has  the  lorm  "(op  type  prim)"  where  op  is 
;;  the  name  ol  the  built-in  (a  symbol),  type  is  the  type  ol  the 
;;  primitive  (an  sexp) ,  and  prim  is  the  translation  inlormation  1 or 
;;  the  built-in  (a  "prim"  sum-ol-products) . 

; ;  The  following  routines  make  it  easy  to  define  entries  in 
; :  standard-prim-bindings : 

(define  inO 

(lambda  (op  type  icode-emitter) 

(list  op  type 

(unique  (inline->prim  ‘(lambda  ()  (,op))  icode-emitter))))) 
(define  ini 

(lambda  (op  type  icode-emitter) 

(list  op  type 

(unique  (inline->prim  '(lambda  (x)  (,op  x))  icode-emitter))))) 
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(define  in2 

(lambda  (op  type  icoda-amittar) 

(list  op  typa 

(unique  (inliae->prim  '(lambda  (x  y)  (,op  x  y))  icoda-emittar))))) 
(define  in3 

(lambda  (op  typa  icoda-amittar) 

(list  op  typo 

(uaiqua  (inline->prim  ‘(lambda  (x  y  z)  (#op  x  y  z))  icoda-amittar))))) 

(define  cast 

(lambda  (op  typa  icoda) 

(list  op  typo  (uaiqua  (cast->prim  icoda))))) 

(define  lib 

(lambda  (op  typa  sexp) 

(list  op  typa  (uaiqua  (lib->prim  saxp))))) 

(daiiaa  asm 

(lambda  (op  typa  label) 

(list  op 

typa 

(unique  (asm->prim  ( instant iata-schema  (parse-schema  type)) 
label))))) 


(define  standard-bindings 

'( 

, (cnst  ’tha-unit  ’unit  (int->icode  unit-type  0)) 

.(asm  'print!  ’(generic  (t)  (->  (sym  t)  unit))  "PRI1TF") 
,(inl  ’put-char  ’(->  (char)  unit)  put-char-prim) 

.(lib  ’put-string  ’(->  (string)  unit)  1-put-string) 

,(in0  void-name  ’(generic  (t)  (->  ()  t))  void-prim) 

; ;  Booleans 

,(in2  ’equiv?  ’(->  (bool  bool)  bool)  (mk-op-prim  'saq)) 
,(in2  ’and?  ’(->  (bool  bool)  bool)  (mk-op-prim  ’and)) 
,(in2  ’or?  ’(->  (bool  bool)  bool)  (mk-op-prim  ’or)) 

,(inl  ’not?  ’(->  (bool)  bool)  (mk-op-prim  ’not)) 

, (ini  'not  ’(->  (bool)  bool)  (mk-op-prim  ’not)) 
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; ;  Characters 

. (cnst  'backspace  ’char  (int->icode  character-type  8)) 

.(cost  ’newline  ’char  (int->icode  character-type  10)) 

, (cast  ’page  ’char  (int->icode  character-type  12)) 

,(cnst  ’space  ’char  (int->icode  character-type  32)) 

.(cast  ’tab  ’char  (int->icode  character-type  9)) 

,(in2  ’ char=?  ’(->  (char  char)  bool)  (mk-op-prim  ’seq)) 

,(in2  ’char<?  ’(->  (char  char)  bool)  (mk-op-pria  ’sit)) 

,(in2  *char>?  ’(->  (char  char)  bool)  (mk-op-prim  ’sgt)) 

,(ia2  ’ char<=?  ’(->  (char  char)  bool)  (mk-op-prim  ’sle)) 

,(in2  ’ char>=?  ’(->  (char  char)  bool)  (mk-op-prim  ’sge)) 

,(lib  ’char-ci=?  ’(->  (ch tor  char)  bool)  (mk-char-ci-pred  char=?) ) 

,  (lib  ’char-ci<?  *(->  (char  char)  bool)  (mk-char-ci-pred  char<?)) 

,(lib  ’char-ci>?  ’(->  (char  char)  bool)  (mk-char-ci-pred  char>?)) 

,(lib  ' char-ci<=?  ’(->  (char  char)  bool)  (mk-char-ci-pred  char<=?) ) 

, (lib  ’ char-ci>=?  * (->  (char  char)  bool)  (mk-char-ci-pred  char>=?) ) 

,(lib  ’char-alphabetic?  ’(->  (char)  bool)  1-char-alphabetic?) 

,(lib  ’ char-nnaeric?  ’(->  (char)  bool)  1-char-numeric?) 

,(lib  ’char-whitespace?  ’ (->  (char)  bool)  1-char-whitespace?) 

,(lib  ’char-lower-case?  ’(->  (char)  bool)  1-char-lower-caae?) 

,(lib  ’char-upper-case?  ’(->  (char)  bool)  1-char-upper-case?) 

,  (lib  ’ char -up case  ’(->  (char)  char)  1-char-upcase) 

,(lib  ’char-downcase  ’(->  (char)  char)  1-char-dowacase) 

,(inl  ’ char->int  ’(->  (char)  int)  cvt-prim) 

,(inl  ’iat->char  ’(->  (int)  char)  cvt-prim) 

; ;  Integers 

,(in2  '=  ’(->  (int  int)  bool)  (mk-op-prim  ’seq)) 

. (in2  ’<  ’(->  (int  int)  bool)  (mk-op-prim  ’sit)) 

. (in2  ’>  ’(->  (int  int)  bool)  (mk-op-prim  ’sgt)) 

,(in2  ’<=  ’ (->  (int  int)  bool)  (mk-op-prim  ’sle)) 

,(in2  ’>=  ’(->  (int  int)  bool)  (mk-op-prim  'sge)) 

,(in2  ’+  ’ (->  (int  int)  int)  (mk-op-prim  ’+)) 

,(in2  ’-  ’ (->  (int  int)  int)  (mk-op-prim  ’-)) 

, (in2  ’*  ’ (->  (int  int)  int)  (mk-op-prim  ’*)) 

,(in2  ’/  ’(->  (int  int)  int)  (mk-op-prim  ’/)) 

,(in2  ’quotient  ’(->  (int  int)  int)  (mk-op-prim  ’/))  ;  helps  in  testing... 

,(inl  ’neg  ’(->  (int)  int)  neg-prim) 

, (in2  ’remainder  ’ (->  (int  int)  int)  (mk-op-prim  ’remainder)) 

,(in2  ’modulo  ’(->  (int  int)  int)  no-prim) 

,(lib  ’abs  ’(->  (int)  int)  ’(lambda  (x)  (il  (<  x  0)  (-  0  x)  x))) 
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;;  Lists 

,  (ini  'anil?  ’(generic  (t)  (->  ((liatol  t))  bool))  null?-pria) 

, (inO  'anil  '(generic  (t)  (->  ()  (liatol  t)))  null-prim) 

,(in2  'cons  ’(generic  (t)  (->  (t  (liatol  t))  (liatol  t)))  (mk-cons-prim  2)) 

,(inl  'car  ’(generic  (t)  (->  ((liatol  t))  t))  (ak-sel-pria  0)) 

,(inl  'cdr  ’(generic  (t)  (->  ((liatol  t))  (liatol  t)))  (mk-sel-pria  1)) 

,(in2  'set-car!  ’(generic  (t)  (->  ((liatol  t)  t)  unit))  no-pria) 

,(in2  'set-cdr!  ’(generic  (t)  (->  ((liatol  t)  (liatol  t))  unit))  no-pria) 

, (lib  ’length  ’(generic  (t)  (->  ((liatol  t))  int))  1-length) 

,(in2  ’append  ’(generic  (t)  (->  ((liatol  t)  (liatol  t))  (liatol  t)))  no-pria) 
,(inl  ’reverse  ’(generic  (t)  (->  ((liatol  t))  (liatol  t)))  no-pria) 

,(in2  ’list-tail  ’(generic  (t)  (->  ((liatol  t)  int)  (liatol  t)))  no-pria) 
,(in2  ’liat-rel  ’(generic  (t)  (->  ((liatol  t)  int)  t))  no-pria) 

,(in3  ’map 

’(generic  (tl  t2)  (->  ((->  (tl)  t2)  (liatol  tl))  (liatol  t2))) 
no-pria) 

,(in3  ’lor-each 

’(generic  (tl  t2)  (->  ((->  (tl)  t2)  (liatol  tl))  unit)) 
no-pria) 

,(in3  ’reduce 

’(generic  (tl  t2)  (->  ((->  (tl)  t2)  (liatol  tl)  t2)  t2)) 
no-pria) 

,(lib  ’liat->atring  ’(->  ((liatol  char))  string)  l-liat->string) 

,(lib  ’atring->liat  ’(->  (string)  (liatol  char))  l-string->list) 

; ;  Ordered  pairs 

,(in2  ’pair  ’(generic  (tl  t2)  (->  (tl  t2)  (pairol  tl  t2)))  (ak-cona-pria  2)) 
.(ini  ’lelt  ’(generic  (tl  t2)  (->  ((pairol  tl  t2))  tl))  (ak-sel-pria  0) ) 

. (ini  ’right  ’(generic  (tl  t2)  (->  ((pairol  tl  t2))  t2))  (ak-sel-pria  D) 

; ;  Reis 

. (ini  'rel  '(generic  (t)  (->  (t)  (relol  t)))  (ak-cons-pria  2)) 

.(ini  ’“  ’(generic  (t)  (->  ((relol  t))  t))  (ak-ael-pria  0)) 

,(in2  ’:=  ’(generic  (t)  (->  ((relol  t)  t)  unit))  asaign-pria) 
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; ;  Strings 

,(in2  ’aake-string  ’(->  (int  char)  string)  1-aake-vector) 

,  (in2  ’string-length  ’(->  (string)  int)  1-vector-length) 

,(in2  ’string-ref  ’(->  (string  int)  char)  1-vector-ref ) 

,  (in2  ’string-set!  ’(->  (string  int  char)  unit)  1-vector-set!) 
f(in2  ’string-fill!  ’(->  (string  char)  unit)  no-pria) 

,  (in2  ’string®?  ’(->  (string  string)  bool)  no-pria) 

,(in2  *string<?  ’ (->  (string  string)  bool)  no-pria) 

,(in2  ’string>?  ’(->  (string  string)  bool)  no-pria) 

,(in2  ’string<=?  ’ (->  (string  string)  bool)  no-pria) 

,(in2  ’string>=?  ’(->  (string  string)  bool)  no-pria) 

,(in2  ’string-ci=?  ’(->  (string  string)  bool)  no-pria) 

,(in2  ’string-ci<?  ’(->  (string  string)  bool)  no-pria) 

,(in2  ’string-ci>?  ’(->  (string  string)  bool)  no-pria) 

,(in2  ’string-ci<=?  ’(->  (string  string)  bool)  no-pria) 

,(in2  ’string-ci>=?  ’(->  (string  string)  bool)  no-pria) 

,(in3  ’substring  ’(->  (string  int  int)  string)  no-pria) 

,(lib  ’string-append  ’(->  (string  string)  string)  l-st,ring-append) 
,(inl  ’string-copy  ’(->  (string)  string)  no-pria) 

,(ini  ’ string->vector  ’(->  (string)  (vectorof  char))  cvt-pria) 
,(inl  ’vector->string  ’(->  ((vectorof  char))  string)  cvt-pria) 

; ;  Syas 

,(inl  ’sya->string  ’(->  (sya)  string)  sym->string-prim) 

.(ini  ’ string->sym  ’(->  (string)  sya)  no-pria) 

. (in2  ’sya=?  ’ (->  (sya  sya)  bool)  (ak-op-pria  ’seq)) 

,(inl  ’hash  ’(->  (sya)  int)  no-pria) 
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; ;  Vectors 

,(ia2  *  make-vector  ’(generic  (t)  (->  (int  t)  (vectorof  t)))  1-make-vector) 
,(inl  ’vector-length 

’(generic  (t)  (->  ((vectorof  t))  int)) 

1-veccor-length) 

,(in2  'vector-ref 

’(generic  (t)  (->  ((vectorof  t)  int)  t)) 

1-vector-ref) 

,(in3  'vector-set! 

’(generic  (t)  (->  ((vectorof  t)  int  t)  nnit)) 

1-vector-set ! ) 

,(in2  ’vector-fill!  ’(generic  (t)  (->  ((vectorof  t)  t)  unit))  no-prim) 
,(lib  ’vector->list 

’(generic  (t)  (->  ((vectorof  t))  (listof  t))) 
l-vector->list) 

, (lib  ’list->vector 

’(generic  (t)  (->  ((listof  t))  (vectorof  t))) 
l-list->vector) 

,(in2  'vector-map 

’(generic  (tl  t2)  (->  ((->  (tl)  t2)  (vectorof  tl))  (vectorof  t2))) 
no-prim) 

,(in3  ’vector-map2 

’(generic  (tl  t2  t3) 

(->  ((->  (tl  t2)  t3)  (vectorof  tl)  (vectorof  t2))  (vectorof  t3))) 
no-prim) 

,(in3  ’vector-rednce 

’(generic  (tl  t2)  (->  ((->  (tl  t2)  t2)  (vectorof  tl)  t2)  t2)) 
no-prim) 

,(in2  ’scan 

'(generic  (t)  (->  ((->  (t  t)  t)  (vectorof  t))  (vectorof  t))) 
no-prim) 

,(in3  ’segmented- sc an 
’(generic  (t) 

(->  ((->  (t  t)  t)  (vectorof  bool)  (vectorof  t))  (vectorof  t))) 
no-prim) 

,(in2  ’compress 

’(generic  (tl)  (->  ((vectorof  bool)  (vectorof  t))  (vectorof  t))) 
no-prim) 

, (in3  'expand  . 

’(generic  (tl) 

(->  ((vectorof  bool)  (vectorof  t)  (vectorof  t))  (vectorof  t))) 
no-prim) 

,(in3  ’eoehift 

’(generic  (tl)  (->  (int  (vectorof  t)  (vectorof  t))  (vectorof  t))) 
no-prim) 
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; ;  Unparsers 

,(lib  ’unparse-bool  ’(->  (bool)  string)  1-unparse-bool) 

,(lib  ’unparse-char  ’(->  (char)  string)  1-unparsa-char) 

,  (lib  ’unparse-int  ’(->  (int)  string)  1-unpaxsa-int ) 

,(lib  ’unparse-string  ’(->  (string)  string)  1-unparse-string) 

, (lib  ’unparse-symbol  ’(->  (sym)  string)  1-unparse-symbol) 

,(lib  ’unparse-unit  ’(->  (unit)  string)  1-unparse-unit) 

, (lib  'unparse-list 

’(generic  (t)  (->  ((->  (t)  string)  (listol  t))  string)) 
1-unparse-list) 

, (lib  ’unparse-vector 

’(generic  (t)  (->  ((->  (t)  string)  (vectorol  t))  string)) 
1-unparse- vector) 

, (lib  ’unparsa-pair 

’ (generic  (r  1) 

(->  ((->  (1)  string)  (->  (r)  string)  (pairol  r  1))  string)) 
1-unpar s e-pair) 

)) 

; ;  Deline  standard-type-environment  and  standard-c-t-env . 

(deline  sb-name  (lambda  (binding)  (car  binding))) 

(deline  sb-type  (lambda  (binding)  (parse-schema  (cadr  binding)))) 

(dalina  sb-prim  (lambda  (binding)  (cadr  (cdr  binding)))) 

(deline  standard-type-environment 

(extend-by-schemas  empty-type-environment 

(map  sb-name  standard-bindings) 

(map  sb-type  standard-bindings))) 

(deline  standard-c-t-env 

(c-t-add-prims  (map  sb-name  standard-bindings) 

(map  sb-prim  standard-bindings) 
empty-c-t-env) ) 


C.9  compiler/misc.fx 

The  contents  of  the  file  compiler/misc.fx: 


;;  -*-  Node:  Scheme;  Package:  SCHEME 
(deline  id  (lambda  (x)  x)) 

(deline  max  (lambda  (nl  n2)  (il  (>  nl  n2)  ni  n2))) 

; ;  List  routines 
(deline  integers-betveen 
(lambda  (lo  hi) 

(il  (>  lo  hi)  (null)  (cons  lo  (integers-betveen  (+  1  lo)  hi))))) 
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(daline  reverse-list  ;  minifx  doesn’t  have  this  built-in. 
(lambda  (1st) 

(latrac  ((rlist  (lambda  (1  r) 

(it  (null?  1) 
r 

(rlist  (cdr  1)  (cons  (car  1)  r)))))) 
(rlist  1st  (null))))) 

(daline  reduce-lelt 
(lambda  (In  1st  saad) 

(latrac  ((loop  (lambda  (1  ▼  ) 

(if  (null?  1) 

V 

(loop  (cdr  1)  (la  v  (car  1))))))) 

(loop  1st  seed)))) 

(del in e  lor- each 
(lambda  (proc  1) 

(il  (null?  1) 
the-unit 

(bagin  (proc  (car  1)) 

(lor-aach  proc  (cdr  1)))))) 

(del in a  lor-aach-2 

(lambda  (proc  Istl  lst2) 

(il  (null?  Istl) 
tha-unit 
(bagin 

(proc  (car  Istl)  (car  lst2)) 

(lor-aach-2  proc  (cdr  Istl)  (cdr  lst2)))))) 

(deline  1st  car) 

(daline  2nd  cadr) 

(daline  ord  caddr) 

(daline  4th  cadddr) 


; ;  Vector  stall 


; ;  String  stall 

(daline  map-string 
(lambda  (proc  str) 

(latrac  ((lan  (string-length  str)) 

(loop  (lambda  (i) 

(il  (<  i  lan) 

(bagin  (string-sat!  str  i  (proc  (string-rel  str  i))) 
(loop  (+  i  l))) 

str)))) 

(loop  0)))) 
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(define  char->string 
(lambda  (c) 

(let  ((«  "x")) 

(begin  (string-set!  s  0  c) 

(string-copy  s))))) 

(define  down- string 

(lambda  (s)  (map-string  char-downcase  s))) 

(define  up-string 

(lambda  (s)  (map-string  char-upcase  s))) 

(define  pad 

(lambda  (s  sz)  (substring  "  ”  0  (-  sz  (string-length  s))))) 

(define  dotm-sym 

(lambda  (s)  (down-string  (symbol->string  s)))) 

(define  up-sym 

(lambda  (a)  (up-string  (symbol->string  s)))) 


; ;  Stream  stuff 

(define  copy-input-sti6-n-to-output-atream 
(let  ((terminators  (char-set  #\newline))) 

(lambda  (fin  font) 

(let  ((line  (read-string  terminators  fin))) 

(if  (eof-object?  line) 
the-unit 
(begin 

(*8cheme-read-char*  fin)  ;  clear  the  newline 
(display  line  font)  (newline  font) 
(copy-input-stream-to-output-stream  fin  font))))))) 


; ;  Wrappers  for  uniqueof  functions  (may  not  be  the  right  semantics  for 
; ;  all  data  types . . . ) 

(define  unique  (lambda  (x)  x)) 

(define  value  (lambda  (x)  x)) 


; ;  Vector  stuff 


(define  generate-vector 
(lambda  (size  proc) 

(letrec  ((ans  (make-vector  size)) 

(loop 

(lambda  (i) 

(if  (=  i  size) 
ans 

(begin  (vector-set!  ans  i  (proc  i)) 
(loop  (♦  i  1))))))) 

(loop  0)))) 
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;;  Faked-up  implement at ion  o f  tuples: 

(define  tuple  list) 

(define  tuple-ref  list -ref) 


C.10  compiler/oc2txt.fx 

The  contents  of  the  file  compiler/oc2txt.fx: 


;;  Mode:  Scheme;  Package:  SCHEME 

;;  oc2trt.fr  —  output  ocode  to  a  file  in  official  DLX  assembly  format 

(define  print-one-instruction 
(lambda  (r  strm) 

(begin 
(match  r 

((ocode"  ’labeldef  (label->rands*  lab)) 

(display  (string-append  lab  ":")  strm)) 

(_  (display  (string-append  "  "  (unparse-ocode  r))  strm))) 

(newline  strm)))) 


Routines  for  printing  stuff,  including  unparsing  results  from  micro-FX 
program  run  in  DLX  simulator 


(define  ertr act -value 

; ;  Unparse  result  from  DLX  simulator 
(lambda  (word  type) 

(match  (prune  type) 

( (base->type‘  ’bool) 

(bool->serp  (not  (=  word  0)))) 

( (baa e-> type"  ’char) 

(char->serp  (int->char  (quotient  word  2)))) 
((base->type*  ’int) 

(int->serp  (quotient  word  2))) 

((base->type*  ’string) 

(string->sexp  (extract-string  word))) 
((base->type*  ’sym) 

(sym->sexp  (extract-symbol  word))) 
((base->type*  ’unit) 

(sym->sexp  ’the-unit)) 
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((compound->type*  ’->  _) 

(unparse-type  type) ) 

((compound->type*  'pair of  at) 

(pair->sazp  (cons  ( extract -value  (gat-slot  word  0)  (car  at)) 

(extract- value  (get-slot  word  1)  (cadr  at))))) 
((compound->type"  ’listof  at) 

(list->saxp  (extract-list  word  (car  at)))) 

((compound->type'  ’vactorof  at) 

(vector->sexp  (axtract-vec  word  (car  at)))) 

(_  * (unrecognized  type  , (unparse-type  type)  .word))))) 

(define  extract-string 
(lambda  (word) 

(lot*  ((vc  (axtract-vec  word  (parse-type  ’char)))) 

(list->string  (vector->list  vc))))) 

(define  extract-symbol 

(lambda  (word)  (string->sym  (get-mem  word)))) 

(define  extract-list 
(lambda  (word  type) 

(if  (=  word  0) 

(null) 

(cons  (extract -value  (get-slot  word  0)  type) 

(extract-list  (get-slot  word  1)  type))))) 

(define  extract-vac 
(lambda  (word  type) 

(letrec  ((len  (de-itag  (get-slot  word  -1))) 

(loop 

(lambda  (v  i) 

(if  (*  i  len) 
v 

(begin 

(vector-set!  v  i  (extract-value  (get-slot  word  i)  type)) 
(loop  v  (+  i  1))))))) 

(loop  (make-vector  len)  0)))) 


(define  type-to-printf -format 

;;  A  munged  version  of  unparse-type  ( . ./frontend/parse.fx)  that  prints 
; ;  out  a  printf-like  format  string  for  printing  the  result  of  the 
;;  computation.  The  printf-like  code  is  written  in  DLX  assembly  code 
;;  in  the  runtime  directory. 

(lambda  (type) 

(if  (recognize-type?  type) 

(string-append  "V"  (type2printf  type)) 

(string-append  "unrecognized  type")))) 
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(define  recognize-type? 

(lambda  (type) 

(match  (prana  typa) 

((base->type*  t)  (if  (mamq  t  ’(int  bool  char  string  sym  unit))  #t  #1)) 
( (compound->type'  ’listof  _)  #t) 

((compound->typa'  t  sub-types) 

(and  (memq  t  ’(listof  pairof  vectorof  ref of  ->)) 

(reduce-left  and?  (nap  recognize-type?  sub-types)  #t))) 

( (unknosm->type*)  #f)))) 

(define  typa2printf 
(lambda  (type) 

(natch  (prone  type) 

((base->type*  ’int)  "d”) 

((base->type*  ’bool)  "b") 

((base->type*  ’char)  "c") 

((base->type'  ’string)  "vc")  ;  strings  are  vec’s  of  chars 
( (base->type*  ’syn)  "s") 

((base->type*  ’unit)  "u") 

((conpound->type“  ’listof  q) 

(match  (prune  (car  q)) 

((tvariable->type'  _)  "Id") 

(ql  (string-append  "1“  (type2printf  qi))))) 

((conpound->typa"  ’pairof  operands) 

(string-append 

Mp.. 

(string-append  (type2printf  (car  operands)) 

(type2printf  (cad r  operands))))) 

((compound->type*  ’vactorof  operands) 

(string-append  ”v"  (type2printf  (car  operands)))) 

( (compound->typa'  ’ref of  operands) 

(string-append  "r“  (type2printf  (car  operands)))) 

((compound->type*  ’->  operands)  "F")))) 


C.ll  compiler/ocode.fx 

The  contents  of  the  file  compiier/ocode.fx: 


; ;  -*-  Mode :  Scheme ;  Package :  SCHEME 

;;  object  code  format 

(define  insn  cons) 

(define  op-code  car) 

(define  op-rands  cdr) 

(define  ocode*  cons') 
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(def iae-datatype  randa 
(rrr->rands  int  int  int) 
(rri->rands  int  int  string) 
(rr->rands  int  int) 
(ri->rands  int  string) 
(r->rands  int) 

(i->rands  string) 
(load->rands  int  int  int) 
(store->rands  int  int  int) 
(nop->rands ) 

(symbol->rands  aym) 
(string->rands  string) 
(label->rands  string) 
(word->rands  string) 

(err->rands  string)) 


C.12  compiler/optimize.fx 

The  contents  of  the  file  compiler/optimize.fx: 

; ;  Nods :  Scheme ;  Package :  SCHEME  -*- 
; ;  icode  optimizer  pasa 

(define  opt imize-i code 
(lambda  () 

(:=  icode-list  (map  prop-returas-down  (*  icode-list))))) 


; ;  Tail  call  handling 

;;  A  tail  call  is  any  call  that  is  immediately  followed  by  a  return  (in 
;;  execution  order).  He  find  them  by  pushing  returns  downward  in  the 
;;  tree,  looking  for  (return  (call  foo))  and  changing  that  to  (jump  foo). 

;;  To  push  returns  downward  in  a  tree,  we  use  the  transformations: 

;;  (return  (if  a  b  c))  — >  (if  a  (return  b)  (return  c)) 

;;  (return  (begin  el  e2  —  en))  — >  (begin  el  e2  (return  en)) 

(define  prop-returas-down 
(lambda  (ic) 

(match  ic 

((body->icode*  ty  n  b)  (body->icode  ty  n  (prop-retums-down  b))) 

((letrec->icode*  n  args  b) 

(letrec->icode  a  args  (prop-returas-down  b))) 
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((retura->icode*  (op->icode"  ty  ’call  args)) 

(op->icod«  ty  ’jump  args)) 

((return->icode*  (op->icode*  ty  ’it  tac)) 

(op->icode  ty 
’if 

(Hat  (car  tac) 

(prop-retums-down  (return->icode  (cadr  tac))) 
(prop-returas-down  (retura->icode  (caddr  tac)))))) 

((retum->icode*  (op->icode'  ty  ’begin  azpra)) 

(latrac  ( (p-r-down-laat 
(lambda  (1) 

(if  (null?  (cdr  1)) 

(liat  (prop-raturaa-doTO  (ratnm->icoda  (car  1)))) 
(cona  (car  1)  (p-r-dosn-laat  (cdr  1))))))) 
(op->icode  ty  ’begin  (p-r-dosn-laat  axpra)))) 

(_  ic)))) 


C.13  compiler/parse.fx 

The  contents  of  the  file  compiler/parse.fx: 

; ; ;  Mode :  Schama ;  Package :  SCHEME 
;  Expraaaion  and  type  parsers 

; ;  Top-level  parser 

(define  parse 

(lambda  (sezpr)  (parse-exp  sexpr))) 

; ;  Parse  a  single  expression 

(define  parse-exp  ;  sexpr  ->  exp 

(lambda  (sexpr) 

(match  sexpr 

((aym->sexp*  sym)  (variable->exp  (ref  unknown- type)  sym) ) 

( (char->saxp'  c)  (char->exp  (ref  character-type)  c)) 

((bool->sexp"  b)  (bool->exp  (ref  boolean-type)  b)) 

((int->sexp‘  n)  (int->exp  (ref  integer-type)  n)) 

((string->sexp*  s)  (string->exp  (ref  string-type)  s)) 

; ;  First  thing  in  list  is  a  SYMBOL 

C(,(sym->sexp*  head)  ,«_)  ((get-parser-for-keyword  head)  sexpr)) 
; ;  Procedure  call  is  the  default 

('(.operator  .Coperands)  (parse-combination  operator  operands)) 

(_  (error  "unrecognized  expression"  sexpr))))) 
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; ;  Para*  a  definition 
(define  para e-definit ion 
(laabda  (aazpr) 

(natch  aazpr 

(‘(define  .name  .value) 

(make-definition  (parse-formal  name)  (parse-exp  value))) 

(_  (error  "invalid  definition"  aexpr))))) 

;;  check-out  a  formal  parameter;  make  aura  it's  not  a  reserved  word, 
(define  parse-formal 
(lambda  (aazpr) 

(match  aexpr 

((sym->sexp"  name) 

(if  (memq  name  (*  all-keywords)) 

(error  "attempt  to  use  reserved  word  as  variable  name" 
aexpr) 

name)) 

(_  (error  "invalid  variable  name"  aexpr))))) 

; ;  Host  of  the  rest  of  this  file  concerns  itself  with  special  forms 
;;  (expressions  of  the  form  (reserved-word  ...)).  Def ine-keyword  is  a 
;;  function  that  defines  a  reserved  word,  associating  it  with  a  function 
;;  that  can  parse  the  named  construct. 

;;  List  of  parsing  functions.  Each  checks  to  see  if  the  nee  keyword 
;;  is  its  own.  and  either  parses  the  whole  thing  or  passes  the  buck, 
(define  keyword-table 
(ref  (lambda  (head) 

(lambda  (sexpr)  ; ;  Procedure  call  is  the  default 

(match  sexpr 

(‘(.operator  .Coperands)  (parse-combination  operator 
operands))  (_  (error  "this  shouldn’t  happen"))))))) 

(define  all-keywords  (ref  (null)))  ;  list  of  keywords. 

(define  get-parser-for-keyword 

(lambda  (name)  ((*  keyword-table)  name))) 

(define  def ine-keyword 
(lambda  (keyword  parser) 

(let  ((current-table  (*  keyword-table))) 

(begin  (:  =  keyword-table 
(lambda  (head) 

(if  (eq?  head  keyword)  parser  (current-table  head)))) 
( : =  all-keywords  (cons  keyword  C  all-keywords))) 
keyword) ) ) ) 

;;  And  here  are  the  parsing  functions... 
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; ;  (symbol  lama) 

»  » 

(del ine-keyword  ’symbol 
(lambda  (saxpr) 

(match  saxpr 

(‘(symbol  , (sym->sexp*  aama))  (sym->exp  (ret  symbol-type)  name)) 
(_  (parsa-arror  saxpr))))) 

; ;  (call  EO  E*) 

>  t 

(deline-keyword  ’call 
(lambda  (saxpr) 

(match  saxpr 

('(call  .operator  , Coper ands) 

(parse-combination  operator  operands)) 

(_  (parsa-arror  saxpr))))) 

; ;  (EO  E*) 

t  t 

(deline  parsa-combination 
(lambda  (operator  operands) 

(combination->exp  (ral  unknown-type) 

(parse-exp  operator) 

(map  parse-exp  operands)))) 


; ;  (il  El  E2  E3) 

>  » 

(deline-keyword  ’il 
(lambda  (saxpr) 

(match  saxpr 

(‘(il  .test  .con  ,alt) 
(conditional->exp  (ral  unknown-type) 
(parse-exp  test) 
(parse-exp  con) 
(parse-exp  alt))) 
(_  (parse-error  saxpr))))) 


; ;  (begin  El  ...  En) 

*  » 

(deline-keyword  ’begin 
(lambda  (saxpr) 

(match  saxpr 

('(begin)  (pars a- exp  ‘(null))) 

(‘(begin  ,exp)  (parse-exp  exp)) 

(  (begin  ,4exps)  (begin->axp  (ral  unknown-type)  (map  parse-exp  exps))) 
(_  (parse-error  saxpr))))) 
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;;  (lambda  (I*)  E) 

i  » 

(def  ine-keyword  ’lambda 
(lambda  (saxpr) 

(match  saxpr 

(‘(lambda  ( .fiformals)  .body) 

( abstract ion->exp  (ref  unknown-type ) 

(map  parse-formal  Normals) 
(parse-exp  body))) 

(_  (parse-error  saxpr))))) 


; ;  LET  is  not  simply  sugar  because  handled  specially  during  typechecking 
;;  (let  ((I  E)*)  EO) 

(def ine-keyword  ’let 
(lambda  (saxpr) 

(letrec  ((parse-binding-spec 
(lambda  (bspec) 

(match  bspec 

(‘(.name  .value) 

(make-definition  (parse-formal  name)  (parse-exp  value))) 

(_  (error  "invalid  binding  specifier"  bspec)))))) 

(match  sexpr 

(‘(let  ( , (sym->sexp_  _)  ,_))  (parse-error  sexpr))  ;  LET  without  a  body 
(‘(let  (.Qbspecs)  .body) 

(binder->exp  (ref  unknown-type) 

(map  parse-binding-spec  bspecs) 

(parse-exp  body))) 

(_  (parse-error  sexpr)))))) 

;;  (letrec  ((I  E)*)  EO) 

•  » 

(def ine-keyword  ’letrec 
(lambda  (sexpr) 

(letrec  ((parse-binding-spec 
(lambda  (bspec) 

(match  bspec 

(‘(.name  .value) 

(make-definition  (parse-formal  name)  (parse-exp  value))) 

(_  (error  "invalid  binding  specifier"  bspec)))))) 

(match  sexpr 

(‘(letrec  ( . (sym->sexp*  _)  ,_))  (parse-error  sexpr))  ;  LETREC  w/no  body 
(‘(letrec  (.fibspecs)  .body) 

(recursion->exp  (ref  unknown-type) 

(map  parse-binding-spec  bspecs) 

(parse-exp  body))) 

(_  (parse-error  sexpr)))))) 

; ;  Sugars 
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; ;  (and)  ==>  #t 

; ;  (and  E)  ==>  E 

;;  (and  EO  E+)  =*>  (if  EO  (and  E+)  #f) 

(define-keyword  'and 
(lambda  (sazpr) 

(match  sazpr 

(‘(and  ,Caxp-list) 

(parsa-axp  (latrac  ((recur  (lambda  (azps) 

(match  exps 

((null*)  *#t) 

C(,axp)  exp) 

((cons'  first  rest) 

‘(if  .first  .(recur  rest)  #f)))))) 

(recur  exp-list)))) 

(_  (parse-error  sexpr))))) 


; ;  (or)  ==>  #f 

; ;  (or  E)  ==>  E 

;;  (or  EO  E+)  ==*>  (if  EO  #t  (or  E+)) 

(def ine-keyeord  'or 
(lambda  (sazpr) 

(match  sazpr 

('(or  , Carp-list) 

(parsa-axp  (latrac  ((recur  (lambda  (axps) 

(match  axps 

((null')  *#f) 

(‘(.exp)  axp) 

((cons'  first  rest) 

‘(if  .first  #t  .(recur  rest))))))) 
(recur  exp-list)))) 

(_  (parse-error  sexpr))))) 


;;  (list  E*) 

*  * 

(daf ine-keyuord.  'list 
(lambda  (sexpr) 

(match  sexpr 

(‘(list  ,«exp-list) 

(parsa-axp  (latrac  ((recur  (lambda  (exps) 

(match  axps 

((null")  ‘(null)) 

((cons'  first  rest) 

‘(cons  .first  , (recur  rest))))))) 

(recur  exp-list)))) 

(_  (pars a- error  sexpr))))) 

(define  parse-error 
(lambda  (sexpr) 

(error  “invalid  expression  syntax"  sexpr))) 


102 


C  pFX/DLX  COMPILER  IMPLEMENTATION _  C.13  compiler / parse,  fx 


; ;  Unparaer 

I ! 

(deline  nnparae 
(laabda  (azp) 

(unparae-exp  azp))) 

(dal in*  unparsa-exp 

(latrac  ((unparae-binding-apeca 
(laabda  (dala) 

(aap  (lambda  (dal) 

' ( , (delinition-aaae  del) 

.(unparae-exp  (dalinition-valua  del)))) 
dala)))) 

(laabda  (azp) 

(match  azp 

( (variable->ezp"  _  var)  (aya->aexp  var)) 

((bool->exp*  _  b)  (bool->aazp  b)) 

((int->axp"  _  n)  (int->sexp  a)) 

((atring->exp"  _  a)  (atring->aazp  a)) 

( (char->azp*  _  c)  (char->aexp  c)) 

((aym->exp'  _  name)  ‘(ayabol  ,(aya->sazp  name))) 
((conditional->exp*  _  teat  consequent  alternate) 

‘ (il  , (nnparaa-azp  teat) 

, (unpara a-azp  conaaqaent) 

, (nnparaa-azp  alternate) ) ) 

( (bagin->exp"  _  ezpra) 

'(begin  ,0(aap  nnparaa-azp  ezpra))) 

( ( abstract ion->azp "  _  foraala  body) 

'(lambda  ( , Clormala )  .(nnparaa-azp  body))) 
((coabination->exp~  _  operator  operanda) 

* ( . (nnparaa-azp  operator) 

,C(map  nnparaa-azp  operanda))) 

( (binder->ezp'  _  dels  body) 

'(let  (,C(unparse-binding-apaca  dala)) 

, (nnparaa-azp  body))) 

((racnraion->azp"  _  dala  body) 

'(latrac  (,«(unparse-binding-specs  dala)) 

, (nnparaa-azp  body))))))) 
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;;  Generic  pretty  printer. 

; ;  pprint-type  i*  a  lunction  on  type*  to  include  the  reconstructed 
;;  type  indorsation  in  the  output. 

(deline  pprint-exp-gen 

(letrec  ((pp-binding-specs 

(lambda  (dele  pprint-type) 

(map  (lambda  (del) 

* ( , (delinition-nama  del) 

, (pprint-erp-gen  (delinition-value  del)  pprint-type))) 
dels) ) ) ) 

(lambda  (exp  pprint-type) 

(match  exp 

( (variable->exp“  ty  var) 

(list  ’variable->exp  (pprint-type  ty)  (sym->sexp  var))) 

((bool->exp*  ty  b) 

(list  *bool->exp  (pprint-type  ty)  (bool->sexp  b))) 

((int->erp*  ty  n) 

(list  ’ int->exp  (pprint-type  ty)  (int->sexp  n))) 

((char->exp*  ty  c) 

(list  *char->exp  (pprint-type  ty)  (char->sexp  c))) 

((string->exp"  ty  s) 

(list  ’string->exp  (pprint-type  ty)  (string->sexp  s))) 

((sym->exp*  ty  name) 

(list  *sym->exp  (pprint-type  ty)  (sym->sexp  name))) 

( (conditional->exp"  ty  test  consequent  alternate) 

(list  *conditional->exp  (pprint-type  ty) 

(pprint-exp-gen  test  pprint-type) 

(pprint-exp-gen  consequent  pprint-type) 

(pprint-exp-gen  alternate  pprint-type))) 

((begin->exp"  ty  exprs) 

(cons  ’begin->exp  (cons  (pprint-type  ty) 

(map  (lambda  (e)  (pprint-erp-gen  e  pprint-type)) 
exprs)))) 

((abstraction->exp"  ty  lormals  body) 

(list  ’abstraction->exp  (pprint-type  ty) 

*  (.dorsals)  (pprint-exp-gen  body  pprint-type))) 
((combination->exp*  ty  operator  operands) 

(list  ’combination->exp  (pprint-type  ty) 

(pprint-exp-gen  operator  pprint-type) 

(map  (lambda  (op)  (pprint-exp-gen  op  pprint-type))  operands))) 
((binder->exp"  ty  dels  body) 

(list  ’binder->exp  (pprint-type  ty) 

(pp-binding-specs  dels  pprint-type) 

(pprint-exp-gen  body  pprint-type))) 

( (recurs ion->exp'  ty  dels  body) 

(list  ’ recurs ion->exp  (pprint-type  ty) 

(pp-binding-specs  dels  pprint-type) 

(pprint-exp-gen  body  pprint-type))))))) 


; ;  ppr inter. 

I  l 

(deline  (pprint-exp  exp)  (pprint-exp-gen  exp  (lambda  (ty)  ’ty))) 
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; ;  pprint  with  types . 

>  * 

(define  (pprint-exp-types  exp) 

(pprint-exp-gen  axp  (lambda  (tr ef)  (unp'irse-type  (*  tref))))) 

; ;  Type  axpraaaion  parser 

»  > 

(define  parse-type 
(lambda  (saxpr) 

(match  saxpr 

((sym->sexp*  sym)  (basa->typa  sym)) 

(‘(->  ( , Carg-types )  .result-type) 

( compound- >typa  arrow-constructor 

(cons  (parse-type  result-type) 

(map  parse-type  arg-types)))) 

( * ( , (sym->sexp*  name)  .fitypes) 

( compound- >type  name  (map  parse-type  types))) 

(_  (error  "invalid  type  expression  syntax"  saxpr))))) 

; ;  Type  expression  unparser 

»  I 

(define  unparse-type 
(lambda  (type) 

(match  (prune  type) 

( (base->type"  sym)  (sya->sexp  sym)) 

((compound->type*  constructor  operands) 

(if  (same-constructor?  constructor  arrow-constructor) 

‘(->  (,«(map  unparse-type  (cdr  operands))) 

, (unparse-type  (car  operands))) 

* ( , (sym->saxp  constructor)  ,«(map  unparse-type  operands)))) 
((tvariable->type_  tvar) 

(sym->sexp  (tvariable->sym  tvar))) 

( (unknown->type ' ) 

’ (*unknown*))))) 

; ;  Parse  a  type  schema  (generic  (I*)  T) 

»  I 

(define  parse-schema 
(lambda  (saxpr) 

(match  saxpr 

(‘(generic  (.taames)  .type) 

(let  ((names  (map  (lambda  (name) 

(match  name 

((sym->sexp"  name)  name) 

(_  (error  "invalid  type  schema  parameter"  name)))) 
names))) 

(let  ((tvars  (map  nev-tvariable  names))) 

(make-schema  tvars 

(substitute-f or-names  (map  tvariable->type  tvars) 

names 

(parse-type  type)))))) 

(_  (make-schema  (null)  (parse-type  sexpr)))))) 
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(define  substitute-for-names 

;  substitute-for-names  is  a  kludge,  to  be  used  only  by  initialization 
;  code.  Other  ways  to  do  this:  (1)  change  the  type  parser  to  take  an 
;  enwironnent  argument;  (2)  generalize  substitute-into-type  so  that  it 
;  can  substitute  for  either  names  or  tvars;  (3)  change  the 
;  representation  of  schemas  so  that  the  generic  variables  in  the  type 
;  are  not  tvars  but  rather  names . 

(lambda  (types  names  type) 

(match  type 

((tvariable->type*  _)  type)  ;shouldn’t  happen 
((base->type*  name) 

(letrec  ((loop  (lambda  (ts  ns) 

(if  (null?  ts) 
type 

(if  (same-name?  name  (car  ns)) 

(car  ts) 

(loop  (cdr  ts)  (cdr  ns))))),) 

(loop  types  names))) 

((compound->typa*  c  args) 

(compound->type  c  (map  (lambda  (arg) 

(snbstitute-for-names  types  names  arg)) 
args))) 

(_  (error  "this  shouldn’t  happen"  type))))) 

(define  unparse-schema 
(lambda  (s) 

(match  s 

((make-schema*  tvars  type) 

‘(generic  (,0(map  sym->sexp  (map  tvariable->sym  tvars))) 

, (unparse-type  type)))))) 


C.14  compiler/system. fx 

The  contents  of  the  file  compiler/system,  fx: 


;;  -*-  Node:  Scheme;  -*- 

#  » 

;;  System  routines,  including  garbage  collector,  used  by  DLX  simulator 
»  » 

;;  System  routines  (which  don’t  live  in  simulated  memory)  have 
;;  negative  addresses  so  we  can  take  their  addresses,  etc,  and  not  get 
; ;  confused. 
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C.14  compiler/ system,  fx 


(define  enter-system-routine-labels 


(lambda  () 
(enter-label 
(ent er-label 
(enter-label 
(enter-label 
(ent er-label 
(enter-label  ", 
(enter-label 
(enter- label 
(enter-label 


.ALLOC"  -4) 

SAVE"  -8) 
RESTORE"  -12) 
..EXIT"  -16) 
.PUTCHAR"  -20) 
.SYM2STRIIG"  -24) 
.SALLOC"  -28) 
.SFREE"  -32) 
.BZERO"  -36))) 


(define  system-routine 

;;  Call  sys  routines  by  passing  calling  this  function  h/  routine’s  addr 
(lambda  (funcnumber) 

(cond  ((=  funcnumber  -4)  (allocate-block-of-memory)) 

((=  funcnumber  -8)  (save-regs-into-frame)) 

((=  funcnumber  -12)  (rastore-regs-from-frame)) 

( (=  funcnumber  -16)  (done-emulating)) 

( (=  funcnumber  -20)  (putchar)) 

( (=  funcnumber  -24)  (sym2string) ) 

( (=  funcnumber  -28)  (stack-allocate-block)) 

((=  funcnumber  -32)  (stack-free-block) ) 

((-  funcnumber  -36)  (zero-block)) 

(else  (error  "unknown  system  routine  called."))))) 

;;  Here  are  the  system  routines.  They’re  basically  the  same  as  the 
; ;  versions  in  "microFX/runtime  (though  some  of  the  names  may  have 
; ;  changed  through  negligence) . 

;;  _SYM2STRIHG 
(define  sym2string 

; ;  Turn  a  symbol  into  a  vector  of  characters 
(lambda  () 

(letrec  ((str  (get-mem  (get-reg  ATEMP))) 

(fill-block 
(lambda  (i) 

(if  (>=  i  (string-length  str)) 
the-unit 

(begin  (set-slot!  (get-reg  ATEMP)  i 

(itag  (char->int  (string-ref  str  i)))) 
(fill-block  (+  i  1))))))) 

(begin  (set-reg!  ATEMP  (itag  (string-length  str))) 

( allocat  e-block-of -memory ) 

(fill-block  0))))) 


;;  .PUTCHAR 

(define  putchar  (lambda  ()  (display  (int->char  (de-itag  (get-reg  ATEMP)))))) 
;;  —EXIT 

(define  done-emulating  (lambda  ()  (:=  ehalt-emulate?*  #t))) 
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;;  .save 

(define  save-regs-into-frame 
(lambda  () 

(letrec  ((f  (get-reg  FP)) 

(loop  (lambda  (rag  slot) 

(if  (=  rag  30) 
the-unit 

(begin  (sat-alot!  f  slot  (get-rag  rag)) 

(loop  (+  1  rag)  (+  1  slot))))))) 

(loop  6  4)))) 

;;  .RESTORE 

(define  restore-regs-from-frame 
(lambda  () 

(latrec  ((f  (get-rag  FP)) 

(loop  (lambda  (rag  slot) 

(if  (=  rag  30) 
the-unit 

(begin  (set-rag!  rag  (get-slot  f  slot)) 

(loop  (+  1  rag)  (+  1  slot))))))) 

(loop  6  4)))) 

; ;  For  the  allocator  and  garbage  collector,  sea  tbe  commentary  in 
;;  'microFX/runtime/alloc.s.  This  version  is  sufficiently  similar 
; ;  that  those  comments  should  apply  here. 

;;  _ZBL0CK 
(define  zero-block 
(lambda  () 

(letrec  ((loop  (lambda  (blk  len)  (if  (=  lea  0) 

the-unit 

(begin  (set-slot!  blk  (-  len  1)  0) 

(loop. blk  (-  len  1))))))) 

(loop  (get-reg  ATEMP)  (de-itag  (get-slot  (get-reg  ATEMP)  -1)))))) 

;;  _SALL0C 

(define  stack-allocate-block 
(lambda  () 

(let*  ((nslots  (de-itag  (get-reg  ATEMP))) 

(new-sp  (-  (get-reg  SP)  (+  (*  nslots  4)  4)))  ;  Extra  slot  for  size 
(stack-size  (-  (-  (~  *entire-memory-size*)  (quotient  new-sp  4))  1)) 
(new-blk  (+  new-sp  5)))  ;  Tagged  ptr  to  new  GC  block 
(begin 

(if  (>  stack-size  (*  *max-stack-size*)) 

(:=  *max-stack-size*  stack-size) 
the-unit) 

(if  (>  stack-size  ("  *stack-size*)) 

(error  "Stack  overflow.") 

(begin 

(:=  *total-allocation*  (+  1  (+  (‘  *total-allocation*)  nslots))) 
(set-slot!  new-blk  -1  (get-reg  ATEMP))  ;  Size 
(set-reg!  ATEMP  new-blk) 

(zero-block) 

(set-reg!  SP  new-sp))))))) 
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C.14  compiler  /system,  fx 


;;  .SFREE 

(define  st.\c'..-free-block 
(lambda  (j 

(let*  ((aslots  (de-itag  (get-slot  (get-reg  ATEMP)  -1))) 
(new-sp  (  +  (get-reg  SP)  (+  (*  aslots  4)  4)))) 

(if  (>=  new-sp  (*  (*  *sntire-memory-size*)  4)) 

(error  "Stack  underflow.”) 

(set-reg!  SP  aew-sp))))) 


;;  .ALLOC 

(define  allocate-block-of-memory 
(lambda  () 

(let*  ((aslots  (de-itag  (get-reg  ATEMP))) 

(p  (allocate-raw-block-of-memory  (+  aslots  1)))) 

(set-slot!  p  -1  (get-reg  ATEMP))  ;  (tagged) 

(set-reg!  ATEMP  p) 

(zero-block) ) ) ) 

(define  allocate-raw-block-of-memory 
(lambda  (aslots) 

(let  ((block  (get-reg  HP))) 

(begin 

(set-reg!  HP  (+  block  (*  aslots  4)))  ;  4  bytes  per  slot 

(if  (<=  (get-reg  HP)  (“  *this-semispace-end*) ) 

(begin 

(:=  *total-allocs*  (+  (*  *total-allocs*)  1)) 

(:=  *total-allocation*  (+  (*  *total-allocation*)  nslots)) 
block) 

(begin 

(let  ((stack-ateap  (get-reg  ATEMP))) 

( int erpr et er-gc ) 

(set-reg!  ATEMP  stack-atemp) ) 

( :*  *num-gcs*  (+  (*  *nua-gcs*)  1)) 

(:=  *gc-words-copied* 

(+  C  *gc-words-copied*) 

(quotient  (-  (get-reg  HP)  (*  *this-semispace*) )  4))) 

(if  (>  (+  (get-reg  HP)  (*  nslots  4))  (“  *this-semispace-end*)) 
(error  "out  of  meaory!") 

(allocate-raw-block-of-memory  aslots) ) )))))) 

(define  stack-depth 

(letrec  ((loop  (lambda  (p  count) 

(if  (even?  p) 
count 

(loop  (get-slot  p  0)  (+  count  1)))))) 

(lambda  ()  (loop  (get-reg  FP)  0)))) 

(define  interpret er-gc 
(lambda  () 

(begin 

(if  (*  *ncisy-gc*) 

(begin  (newline) 

(display  " -  Beginning  garbage-collection")) 

the-unit) 
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; ;  Croat*  frame  on  stack  to  save  old  values  of  registers 
(sot-reg!  ATEMP  (itag  FrameSize)) 

( stack-allocat e-block) 

(set-slot!  (got-reg  ATEMP)  0  (get-reg  FP)) 

(sot-reg!  FP  (get-reg  ATEMP)) 

(set-slot!  (get-reg  FP)  3  (get-reg  EIV)) 

( s  ave-r egs - into-f r ame ) 

; ;  flip  the  semispaces 

(let  ((old-start  (“  *tbis-semispace*)) 

(old-end  (*  *tbis-s*mispae*-end*))) 

(begin  (:»  *tbis-semispace*  (*  *otber-aemispace*)) 

(:=  *otber-semispaco*  old-start) 

(:=»  *tbis-semispac*-*nd*  (“  eotber-semispaee-and*)) 

(:=  *cther-semispace-end*  old-ead))) 

(sot-reg!  HP  etbis-semispacee) ) 

; ;  scan,  the  root  set 

(sot-reg!  FP  (raybe-copy  (get-reg  FP))) 

(set-reg:  V*J,  (aaybe-copy  (get-reg  VAL))) 

; ;  Restore  registers  from  stack  frame  and  pop  stack  frame 
( r estor e-r egs-f rom-f ram* ) 

(set-reg!  ATEMP  (get-reg  FP)) 

(set-reg!  EIV  (get-slot  (get-reg  FP)  3)) 

(set-reg!  FP  (get-slot  (get-reg  FP)  0)) 

(stack-free-block) 

(if  (*  *noisy-gc*) 

(begin 
(newli ie) 

(display  " -  Garbage-collection  done:  ") 

(display  (quotient  (-  (“  *tbis-semispace-end*)  (get-reg  HP))  4)) 
(display  "/") 

(display  (*  *semispace-size*)) 

(display  M  words  free.")) 
tbe-unit) ) ) ) 

(define  in-tbisspace? 

(lambda  (p)  (and  (>=  p  (*  *tbis-semispace*)) 

(<  p  ("  *tbis-semispac*-end*))))) 

(define  in-otberspaco? 

(lambda  (p)  (and  (>«  p  (*  *otber-semispace*)) 

(<  p  (*  *otber-semispace-end*))))) 

(define  in-stack? 

(lambda  (p)  (>  p  (get-reg  SP)))) 
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(define  maybe-copy 

;;  Copy  heap  blocks  into  now  hasp  spaca,  returning  new  result 
(lambda  (p) 

(cond  ((even?  p)  p)  ;  don’t  copy  atoms 

((in-thisspace?  p)  p)  ;  optimization:  obj’s  in  thisS  already  scanned 
((not  (in-otherspace?  p)) 

(begin  (scan-transitively  p)  p))  ;  only  scan  blocks  not  in  old  space 
((odd?  (get-slot  p  -1))  (get-slot  p  -1))  ;  return  forward  addr 

(else  ;;  ok,  we’ve  got  a  live  one. 

(let  ((newp  (get-reg  HP)) 

(nslots  (+  (de-itag  (get-slot  p  -1))  l)))  ;  untagged  wordcount 
(begin  (set-reg!  HP  (+  newp  (*  nslots  4))) 

(set-slot!  newp  -1  (get-slot  p  -1))  ;  size  field 
(copy-block  newp  p  (-  nslots  1))  ;  data  fields 

(set-slot!  p  -1  newp)  ;  set  forward  ptr. 

(scan-transitively  newp) 
newp)))))) 

(define  copy-block  ;  copies  from  slot  0  to  slot  "slot  -  1",  inclusive, 

(lambda  (new  old  slot) 

(if  (<=  slot  0) 
che-unit 

(begin  (set-slot!  new  (-  slot  1)  (get-slot  old  (-  slot  1))) 

(copy-block  new  old  (-  slot  1)))))) 


(define  scan-transitively 
(laabda  (p) 

(letrec  ((loop  (lambda  (slot) 

(if  (<  slot  0) 
the-unit 
(begin 

(set-slot!  p  slot  (maybe-copy  (get-slot  p  slot))) 
(loop  (-  slot  1))))))) 

(loop  (-  (de-itag  (get-slot  p-1))  1))))) 


C.15  compiler/table,  fx 

The  contents  of  the  file  compiler /t  able  .fx: 


polymorphic  symbol-tables  (compile-time  environments) 


There  are  three  components  to  this  package:  a  function  to  create  an 
empty  environment  "(mk-empty-env  empty-function)",  a  function  to  create  a 
"binder"  (i.e.  a  function  to  enter  key/value  pairs  into  the  table) 
"(mk-binder  equality-comparator)",  and  a  polymorphic  lookup  function 
"(lookup  key  onv)". 
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types  used  in  the  comnents  below: 

empty-flag  :  empty-type 
empty-type  ==  value-type 
;  key  :  key-type 
;  env  :  key-type  ->  value-type 


mk-empty-env  :  (poly  (key-type  value-type) 

(->  ((->  (key-type)  value-type))  env)) 


(deline  mk-empty-env 

(lambda  (eapty-ln)  (lambda  (key)  (empty-fn  key)))) 


;;;;;  mk-binder  :  (poly  (key-type  value-type) 

;;;;;  (->  ((->  (key-type  key-type)  bool)) 

; ; ; ; ;  (->  (key-type  value-type  env)  env) 

;;;;;  here,  "env"  is  a  macro,  borrowing  the  definitions  of  key-type  and 
; ; ; ; ;  value-type  from  the  poly  params . 

»  »  t  $  • 

(define  mk-binder 
(lambda  (key=?) 

(lambda  (key  value  env) 

(lambda  (new-key) 

(if  (keys?  key  new-key) 
value 

(lookup  new-key  env)))))) 


; ; ; ; ;  lookup  :  (poly  (key-type  value-type) 

;;;;;  (->  (key-type  (->  (key-type)  value-type)) 

; ; ; ; ;  value-type ) ) 

(define  lookup  (lambda  (key  env)  (env  key))) 
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C.16  compiler/toplevel.fx 


a  handy  utility. . 


(dal in*  li>t2*nv 

(lambda  (empty-ln  key=?  pairs) 

(l*tr*c  ((bind  (mk-binder  k*y=?)) 

(12*  (lambda  (It) 

(il  (null?  1) 
t 

(12*  (cdr  1) 

(bind  (car  (car  1))  (cadr  (car  1))  t)))))) 
(12*  pairs  (mk-empty-env  *mpty-ln))))) 


;  Sample  to  run  through  microlx  to  check  typing...  (yup,  it  worked) 

(run 

’ (letrec  ( (mk-empty-env  (lambda  (empty-llag)  (lambda  (key)  empty-llag))) 
(mk-biader  (lambda  (keys?) 

(lambda  (key  value  env) 

(lambda  (new-key) 

(il  (k*y=?  key  new-key) 
value 

(lookup  new-key  env)))))) 

(lookup  (lambda  (key  env)  (env  key)))) 

(let  ( 

( empty 1  (mk-empty-env  -1) )  (bindl  (mk-binder  =)) 

(empty 2  (mk-empty-env  -2))  (bind2  (mk-binder  aym=?) ) 

) 

(begin 

(+ 

(lookup  1  (bindl  2  100  (bindl  1  99  emptyl  ))) 

(lookup  (symbol  loo) 

(bind2  (symbol  loo)  S00 

(bind2  (symbol  bar)  600  *mpty2)))) 

) 

))) 

M  I  M  I  I  I  I  I  I  I  |  |  >  |  |  m  M  I  >  I  I  M  (  |  M  M  I  I  I  I  »  I  I  ,  M  M  I  I  M  I  I  M  > 


C.16  compiler/toplevel.fx 

The  contents  of  the  file  compiler/toplevel.fx: 

Mode:  Scheme;  Package:  SCHEME  -*- 

( del in*  *v*rbos*-llag*  (rel  #1))  ;;  makes  the  interpreter  noisy... 

(deline  *sil*nt-llage  (rel  #1))  ;;  makes  the  interpreter  SILEIT. 
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; ;  part*  &  microFX  s-expression 

t  • 

(define  test-parse 
(lambda  (sexp) 

(pprint-exp  (parse  sexp)))) 

; ;  parse  a  microFX  s-expression 
;;  (should  reproduce  input) 

•  • 

(define  test-parse-simple 
(lambda  (sexp) 

(unparse  (parse  sexp)))) 


; ;  type-check  a  microFX  s-expression 

I  » 

(define  check 
(lambda  (e) 

(unparse-type  (reconstruct-top  (parse  e))))) 

; ;  type-check  a  microFX  s-expression  and  display  the  expression  tree 
; ;  annotated  with  the  reconstructed  type  information. 

(define  show-type-check 
(lambda  (e) 

(let  ((parse-tree  (parse  e))) 

(begin  (reconstruct -top  parse-tree) 

(pprint -exp-types  parse-tree) ) ) ) ) 


;;  compile  expression  to  icode. 

I  f 

(define  itest-compile 
(lambda  (sexpr) 

(let*  ((exp  (parse  sexpr)) 

(type  (reconstruct-top  exp))) 

(begin 

(newline)  (display  "Type:  ")  (write  (unparse-type  type))  (newline) 
(generate-icode  exp) 

(display-icode-list) ) ) ) ) 


;;  compile  expression  to  optimized  icode. 

»  » 

(define  otest-compile 
(lambda  (sexpr) 

(let*  ((exp  (parse  sexpr)) 

(type  (reconstruct-top  exp))) 

(begin 

(newline)  (display  "Type:  ")  (write  (unparse-type  type))  (newline) 
(generate-icode  exp) 

( opt imize- icode ) 

(display-icode-list) ) ) ) ) 
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C.16  compiler /toplevei.fx 


I 


; ;  compile  expression  to  ocode  (prints  assemblycode) . 

I  * 

(deline  test-compile 
(lambda  (sexpr) 

(let*  ((exp  (parse  sexpr)) 

(type  (reconstruct-top  exp))) 

(begin 

(newline)  (display  "Type:  ")  (write  (unparse-type  type))  (newline) 
(generate-icode  exp) 

(optiaize-icode) 

(generate-ocode) 

(newline)  (display  "Object  code:  ")  (newline) 

(display-ocode-list  (current-output-port) ) 

(newline))))) 


;;  compile  to  ocode,  then  interpret  ocode. 

»  * 

(deline  run 

(lambda  (sexpr) 

(let*  ((exp  (parse  sexpr)) 

(type  (reconstruct-top  exp))) 

(begin 

(il  (*  *  silent -Hag*) 
the-unit 
(begin  (newline) 

(display  "Type:  ")  (write  (unparse-type  type))  (newline))) 
(generate-icode  exp) 

(optiaize-icode) 

(generate-ocode) 

(il  (*  *silent-llag*) 
the-unit 

(begin  (newline)  (display  "Running:  ")  (newline))) 

(init-eaulator) 

(rerun) 

(il  (*  *silent-llag*) 
the-unit 

(begin  (newline)  (show-stats))) 

(extract-value  (get-reg  VAL)  type))))) 


C.16  com  piler/  toplevel.fx 
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;  compile  to  ocoda,  than  interpret  ocoda.  free-up  spara  memory  first! 
;  (worse  for  debugging,  but  batter  for  automatic  tasting.) 


(define  run-m 
(lambda  (saxpr) 

(let*  ((exp  (parse  saxpr)) 

(type  (reconstruct-top  exp))) 

(begin 

(if  (*  *silent-flag*) 
tbe-unit 
(begin  (newline) 

(display  "Type:  '*)  (write  (unparse-type  type))  (newline))) 
(generate-icode  axp) 

(optinize-icode) 

(ganarata-ocoda) 

(if  (*  *silent-flag*) 
the-unit 

(begin  (newline)  (display  "Running:  ")  (newline))) 

(:=  icoda-list  (null)) 

(init-emulator) 

(:=  icoda-to-ba-amitted  (null)) 

(:»  library-icode  (null)) 

(rerun) 

(if  (*  esilent-flag*) 
tbe-unit 

(begin  (nawlina)  (show-stats))) 

(extract -value  (gat-rag  VAL)  type))))) 


; ;  like  run,  but  verbose  (prints  instruction  stream  as  it  executes) . 

I  9 

(define  runv 
(lambda  (saxpr) 

(let  ((old-vflag  (*  averbose-flag*))) 

(begin 

( :=  avarbosa-flag*  #t) 

(let  ((retval  (run  saxpr))) 

(begin  (:*  *varbosa-flag*  old-vflag) 
retval)))))) 


;;  print  out  various  statistics  about  the  run  (currently  only  gc  stats). 

9  9 

(define  show-stats 
(lambda  () 

(begin 

(nawlina) 

(display  "#gc’s=")  (display  (*  anum-gcsa)) 

(display  "  words  copied  by  gc=")  (display  (*  *gc-words-copied*) ) 
(display  "  words  allocated®'*)  (display  (“  *total-allocation*) ) 
(display  "  total-allocs®")  (display  (“  atotal-allocsa)) 
(nawlina)))) 
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;;  compile  {or  dlzsia  into  the  file  “lx. a". 

»  » 

(deline  lx 

(lambda  (sexpr)  (fx-with-outname  sexpr  “lx. a"))) 


;;  compile  lor  dlxsim  into  a  named  file. 

i  i 

(deline  Ix-vith-ontname 
(lambda  (aexpr  outname) 

(let  ((prologname  (string-append  compiler-directory  "/prolog.code")) 
(epilogname  (string-append  compiler-directory  "/epilog. code")) 

(old-pp  (“  *rr-pretty*))) 

(let*  ((exp  (parse  sexpr)) 

(type  (reconstruct-top  exp)) 

(lout  ( open-output -lile  outname))) 

(begin 

( :=  *rr-pretty*  #1)  ;  lo  pprinting  lor  DLX-ASM  output 

(newline)  (display  "Type:  ")  (write  (unparse-type  type))  (newline) 

; ;  Compile  program 
(generate-icode  exp) 

( opt imize- icode ) 

(generate-ocode) 

; ;  Copy  prolog  to  output  lile 
(newline  lout) 

(let  ((prolog  (open-input-lile  prologname))) 

(copy-input-stream-to-output-stream  prolog  lout) 

(close- input -port  prolog)) 

; ;  write  compiled  code  (as  text)  to  output  lile 
(display-ocode-list  lout) 

;;  Output  lormat  string  to  print  the  result  (see  printl.s  in  runtime) 
(display  "RESULT.FORMAT : "  lout)  (newline  lout) 

(display  "  .ascii  "  lout) 

(write  (type-to-pr inti-format  type)  lout) 

(newline  lout) 

(display  "  .byte  OxOa.O"  lout)  (newline  lout) 

(display  "  -align  2"  lout)  (newline  lout) 

;;  Copy  epilog  to  output  file 
(newline  lout) 

(let  ((epilog  (open-input-lile  epilogname))) 

(copy-input-stream-to-output-stream  epilog  lout) 

(close-input -port  epilog)) 

(close-output-port  lout) 
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(display  "Object  coda  has  been  written  to  file  ")  (display  outname) 
(newline) 

(:=  *rr-pretty*  old-pp)))))) 


(define  listing 

(lambda  ()  (do-listing  C  ocode-list)  "fx.asm"))) 

(define  do-listing 
(lambda  (1  outname) 

(letrec  ((font  (open-output-file  outname)) 

(loop  (lambda  (pc  1) 

(if  (null?  1) 
the-unit 

(let  ((new-pc  (match  (car  1) 

((ocode"  ’labeldef  _)  pc) 

((ocode*  ’stringdef  _)  (+  pc  4)) 

(_  (+  pc  4))))) 

(begin 

(newline  font) 

(if  (=  pc  new-pc) 
the-unit 
(begin 

(if  (<  pc  1000)  (display  "0"  fout)  the-unit) 
(if  (<  pc  100)  (display  "O'*  fout)  the-unit) 
(if  (<  pc  10)  (display  "0"  fout)  the-unit) 
(display  pc  fout)  (display  H  fout))) 
(display  (unparse-ocode  (car  1))  fout) 

(loop  new-pc  (cdr  1)))))))) 

(begin  (loop  01) 

(close-output-port  fout) 

(newline) 

(display  "Listing  has  been  written  to  file  ")  (display  outname) 
(newline))))) 


; ;  some  shorthand. . . 


(define  tc  test-compile) 
(define  ic  itest-compile) 
(define  oc  otest-compile) 


;;  print-out  the  list  of  icode. 

»  t 

(define  display-icode-list 
(lambda  () 

(begin 

(newline)  (display  "Icode:  ")  (newline) 
(for-each  display-icode  (“  icode-list)) 
(newline)))) 
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; ;  print-oat  the  list  of  ocode . 

»  » 

(define  display-ocod®-list 
(lambda  (stria) 

(newline)  (display  "Code:  ")  (newline) 

(for-each 

(lambda  (x)  (print-one-instraction  x  strm)) 
(*  ocode-list)) ) ) 


C.17  compiler /ty_recon.£x 


The  contents  of  the  file  compiler/ty_recon.fx: 


;  Mode:  Scheme; 

»  »  » 

;;;  modified  11/14/90  by  jwo  for  mini-fx(90)  version 
;  Contains  the  occars-check  fix 

;  Correction  for  fatare:  when  printing  oat  type 
;  clashes,  shonld  sabstitate  types. 

;  Most,  bat  not  all,  of  a  type  raconstraction  program. 

;  Type  raconstraction 

(define  reconstract-top 
(lambda  (e) 

(begin 

(reset-tvari able-counter ! ) 

(reconstruct  e  standard-type-environment)))) 
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(define  reconstruct 
(lambda  (exp  tenv) 

(■etch  exp 

((variable->exp*  type-ptr  var) 

(memoize-type  type-ptr  (reconstruct-variable  var  tenv))) 

( (bool->erp*  type-ptr  _) 

(■eooize-type  type-ptr  boolean-type)) 

((int->exp*  type-ptr  _) 

(memoize-type  type-ptr  integer-type)) 

((char->exp*  type-ptr  _) 

(memoize-type  type-ptr  character-type)) 

((string->exp"  type-ptr  _) 

(memoize-type  type-ptr  string-type)) 

((sym->exp*  type-ptr  _) 

(memoize-type  type-ptr  symbol-type) ) 

((conditional->exp*  type-ptr  test  con  alt) 

(memoize-type  type-ptr  (reconstruct-conditional  test  con  alt  tenv))) 
((begin->exp*  type-ptr  exprs) 

(memoize-type  type-ptr  (reconstruct-begin  exprs  tenv))) 
((abstraction->exp*  type-ptr  formals  body) 

(memoize-type  type-ptr  (reconstruct-abstraction  formals  body  tenv))) 
( (combination->exp*  type-ptr  op  args) 

(memoize-type  type-ptr  (reconstruct-combination  op  args  tenv))) 
((binder->exp"  type-ptr  defs  body) 

(memoize-type  type-ptr  (reconstruct-binder  defs  body  tenv))) 

( (recursion->exp"  type-ptr  defs  body) 

(memoize-type  type-ptr  (reconstruct -recurs ion  defs  body  tenv))))  ) 


(define  set-type! 

(lambda  (exp  type) 

(match  exp 

( (variable->exp"  type-ptr  _) 
((bool->exp"  type-ptr  _) 
((int->exp"  type-ptr  _) 
((char->exp"  type-ptr  _) 
((string->exp"  type-ptr  _) 

( (sym->exp“  type-ptr  _) 
((conditional->exp*  type-ptr 
((begin->exp*  type-ptr  _) 
((abstraction->exp*  type-ptr 
((combination->exp*  type-ptr 
( (bindar->exp"  type-ptr  _  _) 
((recursion->exp*  type-ptr  _ 


_ ) 


(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 

(memoize-type 


type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type)) 
type-ptr  type))))) 


(define  memoize-type 
(laabda  (type-ptr  type) 
(begin  (:=  type-ptr  type) 
type))) 
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C.17  compiler/ty-recon.fx 


(dal in*  reconstruct- variable 
(lambda  (var  tenv) 

(let  ((tvar-or-schema  (tlookup  tanv  var))) 

(match  tvar-or-achema 

((tvar->tvar-or-schema*  tvar) 

(tvariable->type  tvar)) 

( (schema- >tvar-or-schema"  schema) 

(instantiate-schema  schema)))))) 

(deline  reconstract-conditional  ;  il 

(lambda  (test  con  alt  tenv) 

(begin  (nnily!  (reconstruct  test  tenv)  boolean-type) 

(let  ((con-type  (reconstruct  con  tenv)) 

(alt-type  (reconstruct  alt  tenv))) 

(begin  (unily!  con-type  alt-type) 
con-type))))) 

(deline  reconstruct-begin 
(lambda  (ezprs  tenv) 

(begin  (map  (lambda  (exp)  (reconstruct  exp  tenv))  exprs) 

(expression-type  (car  (list-tail  exprs  (-  (length  exprs)  1))))))) 

(deline  reconstruct-abstraction  ;  lam^-ia 

(lambda  (vars  body  tenv) 

(let  ((new-tvars  (map  no i-f-ariable  vars))) 

(make-arrow-type 
(map  tvariable->type  new-tvars) 

(reconstruct  body 

(rtxcend-by-tvaril.‘les  tenv  vars  new-t var s ) ) ) ) ) ) 

(deline  reco-s  urt-combination  ;  call 

(lambda  (<,  ar  ,«nv) 

(let  ((arg-t,  is  (map  (lambda  (arg)  (reconstruct  arg  tenv))  args)) 

(result-type  (tvariable->type  (new-tvariable  (symbol  result))))) 
(begin  (unily!  (reconstruct  op  tenv) 

(make-arrow-type  arg-types  result-type)) 
result-type)))) 


(deline  reconstruct-binder  ;  let 

(lambda  (dels  body  tenv) 

(reconstruct  body 

( ext  end-by-s  chemas 
tenv 

(map  delinit ion-name  dels) 

(map  (lambda  (binding)  (compute-schema  (reconstruct  binding  tenv) 

tenv) ) 

(map  delinition-value  dels)))))) 
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(del ins  reconstruct-recursion  ;  letrec 

(lambda  (dais  body  tenv) 

(lata  ((names  (map  definition-name  dels)) 

(tvars  (map  new-tvariable  names)) 

(duamy-tenv  (extend-by-tvariables  tenv  names  tvars)) 

(types  (map  (lambda  (del) 

(reconstruct  (definition- value  del)  dummy-tenv)) 
dels) ) 

(new-tenv  (extend-by-schemas 
tenv  names 

(map  (lambda  (t)  (compute-schema  t  tenv))  types)))) 
(begin  (for-each-2  unify!  (map  tvariable->type  tvars)  types) 
(reconstruct  body  new-tenv))))) 

;  Iota:  the  use  of  UIIFYI-LIST  rather  than  FOR-EACH-2  fails  to 
;  correctly  type  (or  find  a  type  error  in)  the  following  example: 

;  (check  '(letrec  ((a  (lambda  ()  3)) 

;  (b  (if  (a)  1  2))) 

;  4)) 


;  Type  schemas 

(define  compute-schema  ; Function  GEH  from  handout 

(lambda  (type  tenv) 

(make-schema  (generic-tvaxiables  type  tenv) 
type))) 

;  ROTE:  generic-t variables  looks  not  only  at  tvariables  in  the 
;  given  type,  but  also  at  tvariables  in  the  leaves  of 
;  the  fully  unwound  version  of  the  given  type.  This  interacts  with 
;  a  similar  unwinding  at  instantiation  time  to  appropriately  handle 
;  generalization.  There  is  potential  confusion  in  that  the  returned 
;  list  may  contain  types  that  are  not  manifestly  in  TYPE  but  are  in 
;  the  fully  unwound  tree  associated  with  it. 

(define  generic-tvariables  ; Compute  FTV(type)  -  FTE(tenv) 

(lambda  (type  tenv) 

(match  (prune  type) 

((tvariable->type”  tvar) 

(if  (generic-tvariable?  tvar  tenv) 

(list  tvar) 

(null))) 

((compound->type*  _  operands) 

(letrec  ((loop  (lambda  (ops  tvars) 

(if  (null?  ops) 
tvars 

(loop  (cdr  ops) 

(union  (generic-tvariables  (car  ops)  tenv) 
tvars)))))) 

(loop  operands  (null)))) 

( (base->type*  _)  (null)) 

(_  (error  "this  shouldn’t  happen"  type))))) 
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(define  (onion  11  12) 

(cond  ((noil?  11)  12) 

((noli?  12)  11) 

((in-tvariable-list?  (car  11)  12)  (onion  (cdr  11)  12)) 

(ala*  (cona  (car  11)  (onion  (cdr  11)  12))))) 

;  [The  following  oaa  oi  MEMQ  ia  a  Mini-FI  type  arror  and  an 
;  abstraction  violation,  bot  it  works  k  is  fast.] 

(dafina  in-tvariabla-list?  memq) 

;  Instantiate  a  type  schema  on  a  fresh  sat  of  type  variables. 

;  [This  corresponds  to  Cardelli’s  "FreshType" .] 

(dafina  instantiate-schema 
(lambda  (schema) 

(snbatitote-into-type 

(map  (lambda  (g)  (tvariable->type  (new-tvariable  (tvariable-id  g)))) 
(schema-generics  schema)) 

(schema-generics  schema) 

(schema-type  schema)))) 

;  [The  following  corresponds  to  Cardelli’s  "Fresh";  note  the  call  to  prone.] 

;  Vote  that  this  onwinds  TYPE  oat  to  the  leaves  when  doing  the  sobstitotion; 
;  this  gnarantaes  that  we  don’t  miss  any  sobstitotions  because  type  itself 
;  isn’t  folly  onwonnd. 

(define  sobstitote-into-type 
(lambda  (types  tvars  type) 

(let  ((type  (prone  type))) 

(match  type 

((tvariable->typa*  tvar) 

(letrec  ((loop  (lambda  (ts  tvars) 

(if  (noil?  ts) 
type 

(if  (same-tvariable?  tvar  (car  tvars)) 

(car  ts) 

(loop  (cdr  ts)  (cdr  tvars))))))) 

(loop  types  tvars))) 

((base->type"  _)  type) 

( (compound->type‘  c  args ) 

(compoond->type  c  (map  (lambda  (arg) 

(sobstitote-into-type  types  tvars  arg)) 
args))) 

(_  (error  "this  shooldn’t  happen"  type)))))) 
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;  Type  environments . 

;  Environments  can  be  extended  in  either  of  two  ways: 

;  extend-by-tvariables  should  be  used  by  lambda  and  letrec  to  bind 
;  variables  to  type  variables 

;  extend-by-schemas  should  be  used  by  let  and  letrec  to  bind  variables 
;  to  type  schemas 

;  Once  constructed,  there  are  two  operations  one  can  perform  on  a 
;  type  environment : 

;  tlookup  :  tenv  *  var  ->  (tvar  +  schema) 

;  does  the  usual  thing. 

;  generic-tvariable?  :  tvar  *  tenv  ->  bool 

;  returns  true  iff  tvar  is  not  free  in  the  type  of  any  var  bound  in  tenv. 

(def ine-datatype  type-environment 

(make-type-env  tlookup-proc  generie-tvariable?-proc)) 

(define  (tenv-lookup  te) 

(match  te 

((make-type-env"  lookup  generic?)  lookup))) 

(define  (tenv-generic?  te) 

(match  te 

((make-type-env*  lookup  generic?)  generic?))) 

(define  extend-by-tvariables 
(lambda  (outer-tenv  vara  tvars) 

(ext end- tenv 
outer-tenv 
vars 

(map  tvar->tvar-or-schema  tvars) 

(lambda  (tvar) 

; ;  tvar  is  an  unconstrained  type  variable. 

(letrec  ((loop  (lambda  (tvars) 

(if  (null?  tvars) 

(generic-tvariable?  tvar  outer-tenv) 

(if  (occurs- in- type?  tvar 

(tvariable->type  (car  tvars))) 
;;  (same-tvariable?  tvar  (car  tvars)) 

#f 

(loop  (cdr  tvars))))))) 

(loop  tvars)))))) 

(define  extend-by-schemas 

(lambda  (outer-tenv  vars  schemas) 

(extend-tenv  outer-tenv 
vars 

(map  schema->tvar-or-schema  schemas) 

(lambda  (tvar) 

(generic-tvariable?  tvar  outer-tenv))))) 
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(define  ertend-tenv  ; Students*  code  should  not  call  this 

(lambda  (outer-tenv  vars  typas  generic-tvariable?-proc) 

(make-type- env 
(lambda  (var) 

(letrec  ((loop  (lambda  (vars  typas) 

(if  (null?  vars) 

(tlookup  outer-tenv  var) 

(if  (same-variable?  var  (car  vars)) 

(car  typas) 

(loop  (cdr  vars)  (cdr  typas))))))) 

(loop  vars  typas))) 
g*neric-tvariable?-proc ) ) ) 

(define  empty-type-environment 
(make-type-env 

(lambda  (var)  (error  "unbound  variable"  var)) 

(lambda  (tvar)  #t))) 

(define  tlookup 
(lambda  (tenv  var) 

((tenv-lookup  tenv)  var))) 

(define  same-variable?  sym=?) 

(define  generic-tvariable? 

(lambda  (tvar  tenv) 

((tenv-generic?  tenv)  tvar))) 

;  Proving  the  correctness  of  this  implementation  of  GEIERIC-TVARIABLE? 

;  is  tricky. 

;  A  type  variable  is  implemented  as  a  record  that  contains  a  ref.  The 
;  global  substitution  is  realized  as  the  collective  contents  of  the 
;  refs  for  all  type  variables. 

(def ine-datatype  t variable 

(make-tvariable  sym  int  (ref of  type)))  ;  id  gennum  ref 

(define  tvariable-id 
(lambda  (tvar) 

(match  tvar 

((make-tvariable*  id  _ )  id)))) 

(define  tvariable-ref 
(lambda  (tvar) 

(match  tvar 

((make-tvariable*  _  r)  r)))) 

(define  tvariable-counter  (ref  0)) 

(define  reset-tvariable-counter ! 

(lambda  ()  (:*  tvariable-counter  0))) 
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(define  new-t variable 
(lanbda  (id) 

(begin  (:*  tvariable-counter  (+  C  tvariable-counter)  1)) 

(nake-tvariable  id  (*  tvariabla-couatar)  (ref  unknown-type))))) 

(define  (tvariable-binding  tvar) 

(*  (tvariable-ref  tvar))) 

(define  ext end-substitution! 

(lanbda  (tvar  binding) 

(begin  (:*  (tvariable-ref  tvar)  binding) 

#t))) 

(define  sane-tvariable? 

(lanbda  (tvarl  tvar2) 

(aaae-ref?  (tvariable-ref  tvarl)  (tvariable-ref  tvar2)))) 

(define  unknown-type  (unknown->type ) ) 

(define  tvariable~>sym 
(lanbda  (tvar) 

(natch  tvar 

((nake-tvariable'  id  gennun  _) 

(string->sya  (string-append  (string- append  (syn->string  id)) 

(string-append  (int->string  gennun)))))))) 


;  Unification 
;  Has  side  effects. 

;  Generates  an  error  if  there  is  no  unification. 

(define  unify! 

(lanbda  (typel  type2) 

(if  (unify! -internal  typel  type2) 
the-unit 

(error  "type  clash"  (unparse-type  typel)  (unparse-type  type2))))) 
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(daf is*  unify! -internal 
(lambda  (typal  typa2) 

(lat  ((typal  (pruna  typal)) 

(typa2  (pruna  typa2))) 

;;  low  if  a  typa  is  a  variable,  it  will  ba  unbound 
(match  typal 

((tvariabla->typa*  vl) 

(match  typa2 

((tvariabla->typa*  v2) 

(if  (sama-tvariabla?  vl  v2) 

#t 

(axtand-substitution!  vl  typa2))) 

(. 

(if  (occurs-in-typa?  t1  typa2) 

#f  ; Circularity 

(artand-substitution!  vl  typa2))))) 

((basa->typa*  cl) 

(match  typa2 

((tvariabla->typa*  v2) 

(axtand-substitution!  t2  typal)) 

((basa->typa*  c2) 

(sama-nama?  cl  c2)) 

(.  #f))) 

((compound->typa*  coni  argsl) 

(match  typa2 

( (tvariabla->typa*  v2) 

(if  (occurs-in-typa?  v2  typal) 

#f 

(axtand-substitution!  v2  typal))) 

((compound->typa*  con2  args2) 

(if  (sama-constructor?  coni  con2) 

(unify !-list  argsl  args2) 

#D) 

(_  #1))))))) 

(dafina  unify* -list 

(lambda  (typasl  typas2) 

(if  (null?  typasl) 

(null?  typas2) 

(if  (null?  typas2) 

#f 

(if  (unify !-intamal  (car  typasl)  (car  typas2)) 
(unify!-list  (cdr  typasl)  (cdr  types2)) 

#f))))) 

;  Chat a  substitutions  of  tvariablas  until  aithar  a  non-tvariabla  or  an 
;  unbound  tvariabla  is  found. 
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(d«fin«  proa* 

(lambda  (type) 

(match  type 

((tTariabla->typa*  tvar) 

(match  (tvariabla-binding  tvar) 

((uakaoTO->typa')  typa) 

(othar-typa  (pruna  othar-typa)))) 

(_  typa)))) 

;  Pravant  circular  substitution*. 

(dafin#  occurs- in-typa? 

(lambda  (tvar  typa) 

(match  (pruna  typa) 

( (tvariabla->typa*  tvar2) 

; ;  pruna  haa  guarantaad  that  tvar2  ia  unbound 
(sama-tvariabla?  tvar  tvar2)) 

((compound->typa"  c  arga) 

(latrac  ((loop  (lambda  (arga) 

(if  (null?  arga) 

«f 

(or  (occura-in-typa?  tvar  (car  arga)) 
(loop  (edr  arga))))))) 

(loop  arga))) 

(_  #f)))) 

(define  tha-unit  (:*  (raf  0)  0)) 


D  /iFX/DLX  Run-time  Implementation 

This  appendix  contains  a  snapshot  as  of  February  12,  1992  of  the  8  source  files  which 
implement  the  runtime  system.  All  of  these  files  are  available  via  FTP. 

The  files  included  in  this  appendix  are  as  follows: 


Filename 

Module 

Purpose 

runtime/Makefile 
runtime/alloc.s 
runtime/epilog. s 
runtime/frames. s 
runtime/lib.s 
runtime/macros. h 
runtime/printf.s 
runtime/prolog.s 

Support 

Runtime 

Output 

Runtime 

Runtime 

Support 

Runtime 

Output 

Makefile  for  processing  runtime  DLX  code 

DLX  Memory  allocation  and  garbage  collection 
DLX  code  to  follow  compiled  code 

Runtime  code  for  register  save  and  restore 
Miscellaneous  runtime  primitives 

Macros  used  in  prolog.s  and  epilog. s 

DLX  code  implementing  printf  utility 

DLX  code  to  precent  compiled  code 

The  index  at  the  end  of  this  document  contains  entries  for  procedures,  shared  vari¬ 
ables,  and  runtime  entry  points. 
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D.l  runtime/ Makefile 


D.l  runtime/Makefile 

The  contents  of  the  file  runtime/Makefile: 


CPP=cc  -E  -traditional 
#CPP“gcc  -E  -traditional 
#CPP*/lib/cpp  -P 


all:  . ./epilog. code  . ./prolog. coda 


. . /epilog. coda:  macros. h  spilog.s  alloc. s  frames.s  print!. s 
$(CPP)  spilog.s  \ 

i  ssd  -g  'a/; .*$!//’  \ 

I  ssd  -g  ’a/  /  /g'  \ 

I  sgrsp  -v  ’ * [  ]*$t|*#.*l 

*  \ 


>  . . /spilog . cods 


lib.  s 


. ./prolog. cods:  macros. h  prolog. s 
$(CPP)  prolog. s  \ 

I  ssd  -g  ’a/;. *$$//’  \ 

I  ssd  -g  ‘a/  / 

I  sgrsp  -v  ’*[ 

*  \ 


>  . ./prolog. cods 


/g'  \ 


D.2  runtime/alloc.s 

The  contents  of  the  file  runtime/alloc.s: 

;;  alloc. s 

;;  Hors  lisa  ths  memory  allocator  and  garbags  collsctor. 

; ;  If  yon  hers  to  change  it ,  then  be  careful ,  and  TEST  OFTEI  (that 
;;  means  REALLY  often),  because  it’s  a  real  pain  to  debug  if  it  gets 
; ;  broken. 

; ;  LEAVE  ALL  THIS  DATA  TOGETHER  (for  addressability) ! 
Memory-deseript  ion : 

.nord  0  ;  Dummy  value 

; ;  Bounds  on  memory  use 
_semispace.size: 

. word  2048 

-stack-size: 

. word  2048 
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;;  Pointers  that  describe  the  two  seaispacea. 
_this_seaispace : 

. word  0 

_this-seaispace_end : 

. word  0 
.other-*  eaispace : 

. word  0 

_other_semispace_end : 

. word  0 

; ;  Statistics 

nnm  gee :  ;  count  of  gc’s  performed 
. Bor d  0 

_gc_Hords_copied:  ;  number  of  sords  scanned  by  all  gc’s 
. word  0 

_total_allocation:  ;  total  tuords  allocated  (ever) 

. eord  0 
total  allocs : 

. word  0 
_aax_stack_siz6 : 

. Bord  0 


; ;  Flags  and  aisc . . . 
_jnst_did.a.gc : 

. word  0 


; ;  Address  above  locations  by 
tdefine  senispace_size 
tdefine  stack-size 
tdefine  this_seaispace 
tdefine  this-seaispace.end 
tdefine  other_s*aiapace 
tdefine  other_s*ei»pace_and 
tdefine  nna-gcs 
tdefine  gc_sords-copied 
tdefine  total-allocation 
tdefine  total_allocs 
tdefine  a az_s tack-size 
tdefine  jnat-did-Sugc 


offsets  froa  Neaoryjdescription 
-seaispace-size-Meaory-description 
-Stack-size-Neaory -description 
-tkis-seaispace-Neaory-description 
-this-seaispace-end-Neaoryjdescription 
_other-s  eaispace-Neaory_des  cr  ipt  ion 
_other_a  eaispace_end-Meaory_deacri.pt  ion 
_nua-gcs-Meaoryjdescription 
-gcjords.copied-Memory  .descript  ion 
_total_allocat  ion-Meaory_des  cr  ipt  ion 
-t  o  t  al-all  o  c  s  -  M  eaory-de  s  cr  ipt  i  on 
-Baz-stack_s  ize-Meaory_description 
-just-didJugc-Meaoryjdescription 


;;  _init_mntiae: 

; ;  Initialize  mntiae  systea.  Puts  ataxtup  values  in  the  runtime 

;;  system’s  variables  and  initializes  SP,  and  HP.  Trashes  ATEMP,  RETADR; 
; ;  zeros  ARGO — ARG3 . 

-init-runtiae : 

; ;  Initialize  aeaory-aanageaent  registers 

lhi  SP,(TOTALMEMSIZE-4)»10 

ori  SP,SP , (T0TALMEMSIZE-4)A0xffff 

lhi  HP,(-endprograa+l)»10  ;  tag  this  pointer, 

ori  HP, HP,  (-endprograa+DftOxffff 
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; ;  Initialize  the  semispace  descriptions 
Thi  ARG1 ,  (Hemory_description)>>16 

ori  ARG1  ,  ARG1 ,  (Memoryjiescription)  AOxili  t 

Is  ARG3 ,  semispac  e_s  ize  ( ARG1 ) 

slli  ARG3,ARG3,2  ;  *4  =  byte  count 

se  this_semispace(ARGl)  ,HP 

addu  ARG2 ,  HP ,  AR.G3 

SB  this_seaispace_end(ARGl)  ,ARG2 

sb  other  jemispace(ARGl)  ,ARG2 

addu  ARG2.ARG2.ARG3 

su  other  jefflispac*_end(AHGl)  ,ARG2 

;;  Clear  statistics... 
sb  nusLgcs  (ARG1 ) ,  ZERO 

sb  gc_aords_copied(ARGl)  .ZERO 

sb  total^allocation(ARGl)  .ZERO 

sb  total_allocs(ARGl)  .ZERO 

sb  max_stackjize(ARGl)  .ZERO 

or  ARG1.ARG1.ZERQ 

or  ARG2.ARG1 .ZERO 

or  ARG3 . ARG1 , ZERO 

jr  RET ADR 

nop 


; ;  -ZBLOCX  —  zero  gc  block 
; ;  On  entry: 

; ;  ATEMP  contains  (tagged)  pointer  to  GC  block  (with  size 

; ;  slot  tilled  in) . 

»  • 

; ;  On  return: 

! I  Data  slots  ot  GC  block  are  all  zero . 

; ;  ATEMP  still  points  to  GC  block 

-ZBLOCK: 


sb  O(SP) , ARG1 

sb  -4(SP) , ARG2 

1b  ARG 1,-1 (ATEMP) 

or  ARG2, ZERO, ATEMP 

zblock_loop: 

beqz  ARG 1 , zblockjdone 
nop 

sb  3(ARG2) .ZERO 

addui  ARG2.ARG2.4 

j  zblock-loop 

subui  ARG1.ARG1 ,2 

zblockjdone : 

1b  ARG2,-4(SP) 

jr  RET ADR 

1b  ARGl.O(SP) 


;  tree-up  a  temp 
;  load  (tagged)  size  into  ARG2 

;  zap  a  uord 
;  inc  pointer 

;  dec  count 


131 


D.2  runtime/alloc.s 


D  (iFX/DLX  RUN-TIME  IMPLEMENTATION 


; ;  SALLOC  —  stack  allocation  of  GC  block 
; ;  On  entry : 

;;  ATEMP  contains  the  (tagged)  number  of  words  to  allocate. 

»  » 

; ;  On  return: 

; ;  ATEMP  contains  a  (tagged)  pointer  to  a  new  gc  block  of 

;;  the  requested  size.  This  block  has  its  size  slot  filled 

; ;  and  all  data  slots  sat  to  zero 

; ;  SP  decremented  to  make  room  for  new  block 

; ;  All  other  rags  are  preserved 

jSALLOC: 


subu 

SP.SP, ATEMP 

subu 

SP.SP, ATEMP 

subui 

SP.SP, 4 

sw 

0(SP) , ARG1 

;  free-up  a  temp 

sw 

-4(SP)  ,  ARG2 

;  free-up  another  temp 

sw 

-8(SP) , ARG3 

;  free-up  another  temp 

lhi 

ARG1 .  (Memory  _description)>>16 

ori 

ARG1 , ARG1 ,  (Memory .description) AOxffff 

lw 

ARG2,  stackjize(ARGl) 

slli 

ARG2.ARG2.2 

;  *4  =  byte  count 

lhi 

ARG3,  (T0TALMEMSIZE-4)»18 

ori 

ARG3 , ARG3 , (TOTALMEMSIZE-4) AOxffff 

subn 

ARG2.ARG3.ARG2 

sit 

ARG2,  SP.  ARG2  ;  Stack 

overflow? 

bnez 

ARG2.  stack_overllow 

nop 

addui 

ARG3,  SP,  5 

;  Tagged  ptr  to  new  block 

sw 

-1(ARG3) ,  ATEMP 

;  Save  size  into  size  slot 

; ;  Increment  statistics 

srli 

ATEMP, ATEMP ,1 

;  get  untagged  wordcount 

lw 

ARG2 ,  total^allocation(ARGl ) 

addu 

ARG2.ARG2, ATEMP 

;  inc  the  statistic. 

addui 

ARG2 , ARG2 , 1 

;  (account  for  size  fields  too) 

sw 

,total_allocation(ARGl) ,arg2 

or 

ATEMP, ZERO, ARG3 

;  move  pointer  to  ATEMP 

lw 

ARG3,-8(SP) 

;  reload  the  temp  registers 

lw 

ARG2,-4(SP) 

;  A  go  zero  block 

j 

-ZBLOCX 

lw 

ARG1,0(SP) 

132 


D  pFX/DLX  RUN-TIME  IMPLEMENTATION _ D.2  runtime/aJloc.s 


sovjssg: 

.ascii  "Stack  overfloe.  Dying..." 

.  byte  OxOa.OxOO 

.align  2 
stack-overllos: 

lhi  ARGO,  (print£_closure+l)»16 

ori  ARGO,  ARGO,  (printf_closure+l)*Oxffff 

lhi  ARG1 ,  (sovjnsg)»16 

ori  ARG1.ARG1,  (sovjasg)AOxffff 

Is  ATEMP,  3 (ARGO)  ;  Jump  to  printf 

jalr  ATEMP  ;  / 

nop 

trap  0  ;  Die 

nop 


; ;  SFREE  —  stack  Ires 

_SFREE: 

Is  ATEMP,  -l(ATEMP)  ;  Get  (tagged)  sord  count 

addu  SP.SP, ATEMP 

addu  SP.SP, ATEMP 

addui  SP.SP, 4  ;  (Plus  one  lor  size  slot). 

lhi  ATEMP.  (T0TALMEMSIZE-4)»18 

ori  ATEMP. ATEMP ,(T0TALMEMSIZE-4)*0xf Iff 

sgt  ATEMP ,SP, ATEMP 

bnez  ATEMP ,  stacknnderf  los 

nop 

jr  RET  ADR 

nop 


suvjssg: 

.ascii  "Stack  underllos.  Dying..." 

.byte  OxOa.OxOO 
.align  2 
stackjunderlloe : 

lhi  ARGO,  (printf_closure+l)»16 

ori  ARGO,  ARGO,  (printf  .jclosure+DtOxfffl 

lhi  ARG1 ,  (suvjssg)»16 

ori  ARG1 ,  ARG1 ,  (suvjnsg)AOxlllf 


Is 

ATEMP,  3(ARGO) 

;  Jump  to  printf 

jalr 

ATEMP 

;  / 

nop 

trap 

0 

;  Die 

nop 

; ;  -ALLOC  —  allocate  gc  block 

on  heap 

f  » 

t  * 

Same  as  SALLOC  except  on  heap.  May  initiate  a  garbage 
collection,  shich  sill  change  the  value  of  pointers  into 

»  » 

the  current  space. 

39 

O(SP) , ARG1 

;  free-up  a  temp 

39 

-4(SP) , ARG2 

;  free-up  another  temp 

89 

-8(SP) , ARG3 

;  free-up  yet  another  temp 
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lhi 

ARG1 ,  (Memory  jdascript  ion  )»lfl 

ori 

ARG1 , ARGi , (Memory  _description)kOxffff 

lc 

ARG2 ,this_semispace_end(ARGl)  ;  get  end  ptr  ready... 

or 

ARG3,ZER0,HP 

;  get  pointer  to  the  nes  block 

addu 

HP, HP, ATEMP 

;  inc  HP  to  next  i ree  mem 

addu 

HP , HP , ATEMP 

;  (ATEMP  Bas  tagged  wordcount . . . ) 

addu 

HP,  HP, 4 

;  add  a  word  for  a  size  field 

sgt 

ARG2 , HP , ARG2 

;  is  hp  over  the  end? 

beqz 

ARG2 ,  need_no^gc 

;  if  not.  Be’ re  ok. 

uop 

1 1  Uh¬ 

-oh,  se  need  to  do  a  gc. 

ls 

ARG3 , -8(SP) 

;  reload  the  temp  registers 

Is 

ARG2,-4(SP) 

;  ft  go  collect  (k  retry  alloc) 

3 

gc 

Is 

ARGl.O(SP) 

as 

-1(ARG3), ATEMP 

;  stick  the  size  into  the  nes  blk 

; ;  Clear  recursion-check  Hag  to  indicate  it  sorked  this  time 

av 

jus t_did_a  gc ( ARG 1 )  , ZERO 

; ;  Increment  statistics 

srli 

ATEMP .ATEMP, 1 

;  change  ATEMP  to  untagged  wordcount 

Is 

ARG2  ,total_allocat  ion  (  ARG  1 ) 

addu 

ARG2.ARG2, ATEMP 

;  inc  the  statistic. 

addui 

ARG2 , ARG2 , 1 

;  (account  for  size  fields  too) 

SB 

totaljallocation(ARGl)  ,ARG2 

lB 

ARG2 ,  total_allocs(ARGl ) 

addui 

ARG2 , ARG2 , 1 

SB 

total jallocs  (  ARG  1 ) ,  ARG2 

or 

ATEMP, ZERO, ARG3 

;  move  pointer  to  ATEMP 

1b 

ARG3,-8(SP) 

;  reload  the  temp  registers 

1b 

ARG2,-4(SP) 

;  k  go  zero  block 

j 

JZBLOCK 

1b 

ARG1 ,0(SP) 
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D.2  runtime/ alloc,  s 


gc  —  garbage  collector 

On  entry: 

HP  is  garbage. 

ATEMP  (still)  contains  tie  (tagged)  number  of  words  to  allocate. 
On  return: 

All  reachable  data  has  been  moved  to  the  (old)  other 
space,  and  the  spaces  have  been  swapped.  The  root  set 
is  all  registers  except  ZERO ,  HP,  SP,  ATEMP,  and  RETADR 
HP  points  to  usable  space  in  a  (new)  semispace 
ATEMP  contains  a  pointer  satisfying  the  alloc  request 
All  other  regs  are  preserved  modulo  forwarding  due  to  copying 
We  return  to  address  in  RET ADR 


sw  O(SP),  ATEMP 

sw  -4(SP) ,  RETADR 

subui  SP,  SP,  8 


»  * 

We’ll  push  a  frame  onto  the  stack. 

making  the  root  set  be 

$  * 

just  FP  and  VAL  (since  VAL  isn’t  saved  into  the  frame). 

jal 

JS  ALLOC 

;  Alocata  frame  on  stack 

ori 

ATEMP,  ZERO,  2*(FrameSize) 

;  (Tagged)  size  of  frame 

sw 

3(ATEMP) ,FP 

;  Link  frame  into 

or 

FP, ZERO, ATEMP 

;  dynamic  chain 

jal 

-SAVE 

sw 

1S(FP) ,E1V 

;  (lot  saved  by  -SAVE) 

lhi 

ARG1 ,  (Memory  _description)»16 

ori 

ARG1 ,  ARG1 ,  (Memory  _description)kOxffff 

;;  Check  to  see  if  we  recursed;  if  so. 

out  of  memory . . . 

lw 

ARG2 , j ust-did  a  g c ( ARG 1 ) 

bnez  ARG2 , gc _loop-dat acted  ;  EEEEE! 

EEEEEEEEKKKKKKKKXKK! ! ! ! ! ! 

nop 

; ;  Flip  the  semispaces 

Iv , 

ATEMP ,  this.3  emispac  e_end  (  ARG  1 ) 

lw 

HP,  other  _semispace_end(ARGl) 

tv 

otherj  emispac  a_end(  ARG  1) ,  ATEMP 

sw 

this-semispace-end(ARGl)  ,HP 

lw 

ATEMP , this_a  emispac  a ( ARG 1 ) 

lw 

HP ,  other-s  emi  spac  e  (  ARG  1 ) 

sw 

other_semispace(ARGl) ,  ATEMP 

tv 

thisjemispace(ARGl)  ,HP 

;;  That  cleverly  left  HP  properly  initialized.  low  scan  root  set. 
j  al  maybe-copy 

or  ARG2.ZER0.FP 

or  FP, ZERO, ATEMP 
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jal 

maybe.copy 

or 

ARG2 ,  ZERO ,  VAL 

;  VAL  isn't  in  the  frame 

or 

VAL, ZERO, ATEMP 

;;  At  this  point,  garbage  collection  is  done.  Seed  to  update 
;;  statistics,  restore  registers  and  the  stack,  and  retry 
; ;  allocation. 


; ;  nark 

-up  statistics... 

lw 

ARG2, nuoLgc s ( ARG 1 ) 

;  inc  gc  count 

addui 

ARG2.ARG2.1 

sw 

num_gcs(ARGl) , ARG2 

lw 

ARG  3  ,this_semispace(ARGl) 

;  get  bottom  of  this  space 

subu 

ARG3 , HP , ARG3 

;  subtract  it  from  current  hp 

srai 

ARG3.ARG3.2 

;  change  bytecount  to  wordcount 

lw 

ARG2,gcjsords_copied(ARGl) 

;  add  this  to  total  GC  charge 

addu 

ARG2 , ARG2 , ARG3 

sw 

gc_words_copied(ARGl ) ,  ARG2 

; ;  Set  flag  so  next  alloc  (called  Iron  end  of  GC)  will  fail  if  no  mem 
sw  justjiid.,a  gc(ARGl) ,  ARG1 

;;  Restore  regs,  pop  activation  frame  from  dyn  chain,  free  mem  it  used 
jal  .RESTORE 

sw  15(FP) ,EIV  ;  (lot  restored  by  .RESTORE) 

or  ATEMP,  ZERO,  FP 

lw  FP,  3(ATEMP) 

jal  JSFREE 

nop 

; ;  Restore  resgisters  we  saved  right  at  start  of  gc 
addui  SP,  SP,  8 

lw  RET ADR,  -4(SP) 

lw  ATEMP,  0(SP) 

;;  retry  the  alloc,  setting  justjdid  flag  so  we  can  detect  out-of-mem 
j  .ALLOC  ;  go  re-try  the  allocation. . . 

nop 


136 


D  fiFX/DLX  RUN-TIME  IMPLEMENTATION 


D.'2  runtime/alloc. s 


;;  gc_loop_detected  —  didn't  free  enough  mem;  print  message  and  die 


out_mem_msg: 

.ascii  "Insufficient  memory  to  process  alloc  request.  Dying... 
.byte  OxOa.OxOO 

.align  2 
gc_loop_detected: 

lhi  ARGO,  (printf_closure+l)»l6 

ori  ARGO, ARGO,  (printf_closure+l)AOxffff 

lhi  ARG1,  (outjsem_msg)»16 

ori  ARG1.ARG1,  (out_mem_msg)ltOxfff  f 

lw  ATEMP,  3 (ARGO)  ;  Jump  to  print! 

jalr  ATEMP 

nop 

trap  0  ;  Die 

nop 


•  I 


; ;  maybe_copy 
; ;  On  entry : 

; ;  ARG1  points  to  Memoryjdescription 

; ;  HP  points  to  !ree  memory  in  the  (new)  semispace  (this_semispace) 
; ;  ARG2  contains  a  value  to  be  copied  (possibly) 

9  9 

; ;  On  exit : 

;;  I!  thing  in  ARG2  is  a  tagged  pointer,  recursively  maybe_copy 
;;  each  slot.  1!  that  pointer  points  into  the  old  semispace,  copy 
;;  object  into  new  semispace. 

; ;  ATEMP  is  either  old  ARG2  il  original  wasn't  a  tagged 
; ;  pointer  into  old  semispace,  or  pointer  to  new  copied 

;;  block  i!  it  was  such  a  pointer. 
maybe_copy : 


sw 

0(SP) , RET ADR 

subui 

SP.SP.4 

or 

ATEMP, ZERO, ARG2  ;  By  default,  return  original  value 

;;  If 

not  a  pointer,  then  we’re  done 

andi 

ARG3.ARG2.1 

beqz 

ARG3 ,  maybe.c  opy  jdone 

nop 

;;  if 

pointer  into  this-space,  just  return  it  <==  it’s  scanned  already 

lw 

ARG4,this_semispace(ARGl) 

•ge 

ARG3 , ARG2 , ARG4 

;  ARG3:=  p  >=  this-semispace 

beqz 

ARG3 ,  check_4_seaispace_ptr 

lw 

ARG4 ,  t  hi  s_s  emi  spac  e_end  (  ARG 1 ) 

sit 

ARG3 , ARG2 , ARG4 

;  ARG3:=  p  <  this_semispace_end 

bnez 

ARG3  ,maybe_copy_done 

nop 
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;;  pointer  to  otherspace  =>  copy  object  AID  scan  object 
;;  io inter  somewhere  else  =>  OIL?  scan  object 
check_4_se*j.space_ptr : 


lw 

ARG4 ,  other j  emispac  e  (  ARG 1 ) 

sge 

ARG3.ARG2.ARG4 

;  ARG3:=  p  >=  other jemispace 

beqz 

ARG3,scan_transitively 

lw 

ARG4 ,  other  j  emispac  e.end  (  ARG  1 ) 

sit 

ARG3 , ARG2 , ARG4 

;  ARG3 :  =  p  <  other j emspac e.end 

beqz 

nop 

ARG3 ,  scan_transit  ively 

;;  For  semispace  ptrs,  don’t  chase  if  it’s  a  forwarded  pointer 


is  _semispace_ptr : 


lw 

ATEMP, -1(ARG2) 

andi 

ARG4, ATEMP, 1 

bnez 

ARG4  ,maybe_copy_done 

nop 

;;  Ok, 

we’ve  got  a  live  one. 

or 

ARG3, ZERO, ATEMP 

or 

ATEMP, ZERO, HP 

addu 

HP.HP.ARG3 

addu 

HP.HP.ARG3 

addui 

HP, HP, 4 

sw 

-l(ATEMP) , ARG3 

sw 

-1(ARG2), ATEMP 

jal 

copy-block 

nop 

;  Get  size  or  forwarding  ptr 
;  is  this  forwading  pointer? 
;  yup  ==>  just  return  it. 


get  (tagged)  size  in  words 
quick  *n  dirty  alloc 
/ 

/  (two  times  to  get  byte  count) 

/  (add  4  bytes  for  size  slot) 
stash  block  size  (tagged  in  words) 
set  forwarding  address, 
copy  old  block  to  new  block 


scan-transitively: 

;;  Here,  ATEMP  points  to  a  block  whose  contents  need  to  be 
;;  "maybe.copied” .  loop  over  it,  doing  the  proper  thing. 


; ;  ARG2 ,  ARG3  and  ARG4  are  free . 
subui  SP.SP.12 
sw  4(SP) ,  ATEMP 

or  ARG3, ZERO, ATEMP 

lw  ARG4,-1(ARG3) 

s  c  an.tr  ans  it  ively_Loop : 

beqz  ARG4,  scan.tr  ans  it  ivelyjione 

nop 


lw 

ARG2,3(ARG3) 

sw 

8(SP)  ,ARG3 

sw 

12(SP) , ARG4 

jal 

maybe_copy 

nop 

lw 

ARG4, 12(SP) 

lw 

ARG3,8(SP) 

sw 

3(ARG3) .ATEMP 

addui 

ARG3, ARG3.4 

j 

s  can-transit  ively  JLoop 

subui 

ARG4 , ARG4 , 2 

scan-transit  ivelyjdone : 

lw 

ATEMP,  4(SP) 

addui 

SP.SP.12 

;  save  3  words  live  data  thru  recursion 
;  Save  original  value 
;  block  pointer  into  ARG3 
;  (tagged)  wordcount  in  ARG4 

;  quit  when  count  is  zero 
;  get  a  word 

;  Save  registers  for  recursive  call 

;  / 

;  maybe-copy  the  item 

;  restore  regs  after  recursive  call 

;  / 

;  replace  old  value 
;  inc  pointer 

;  decrement  (tagged)  count. 

;  Restore  original  value  of  pointer 
;  Pop  off  spaced  used  during  recursion 
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maybe.copy.done : 

addui  SP,SP,4 
Is  RETADR, O(SP) 

jr  RETADR 

nop 


;;  copy_block  —  copy  old  block  to  new  block. 

> ;  ARG2  points  to  old  block  (with  forwarding  ptr  in  size  slot) 

; ;  ATEMP  points  to  new  block  (with  valid  size  in  size  block) 

;;  ARG2,  ARG3  and  ARG4  are  trashed;  all  rest  (incl.  ATEMP)  presrved 
copy_block : 


lw 

ARG3,-1( ATEMP) 

;  Get  size  in  words  (tagged) 

addu 

ARG3.ARG3.ARG3 

;  *  2  =  untagged  byte  count 

addn 

ARG2 , ARG2 , ARG3 

;  point  to  end  of  old  block 

addu 

ARG3, ATEMP ,ARG3 

;  point  to  end  of  new  block 

copy  JslockJLoop : 

subu 

ARG4.ARG3, ATEMP 

;  compare  ptr  to  beginning  of  block 

beqz 

ARG4 ,  copyJalock_done 

;  done  if  no  more  to  copy. 

nop 

lw 

ARG4,-1(ARG2) 

;  move  a  word 

sw 

-1(ARG3) , ARG4 

;  / 

subui 

ARG2.ARG2.4 

;  adjust  oldblock  pointer 

j 

copyJ)lock_loop 

;  (loop) 

subui 

ARG3 , A&G3 , 4 

;  adjust  newblock  pointer 

copy  .block-done : 

jr 

RETADR 

;  ARG2  and  ATEMP  are  what  they  were. 

nop 

;;  statistics  —  print  memory  statistics. 

stat-foxnat : 

.ascii 

"fgc'ssXd  words  copied  by  gc=%d  words  allocated='/.d  total  allocs 

.byte 

OxOa.O 

.align 

2 

STATISTICS: 

sw 

O(SP),  RETADR 

sw 

4(SP),  ARGO 

sw 

8(SP),  ARGi 

sw 

12(SP) ,  ARG2 

sw 

16(SP) ,  ARG3 

sw 

20(SP) ,  ARG4 

sw 

24(SP) ,  ARG6 

subui 

SP.SP.28 

lhi 

ARGO,  (printf_closure+l)»16 

ori 

ARGO ,  ARGO ,  (printf_closure+  i )  AOxffff 

lhi 

ARGI,  (stat.lormat)»16 

;  Get  format  strinz 

ori 

ARGI,  ARGI,  (stat_format)tOxffff  ;  / 
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lhi 

ATEMP,  (Memory  _description)»16 

ori 

ATEMP ,  ATEMP ,  (Memo  ry_descript  ion)*0xffff 

lw 

ARG2 ,  nusugc  s  ( ATEMP ) 

;  get  count  of  GC’s  perfora 

slli 

ARG2.ARG2, 1 

;  tag  the  value  for  PRI1TF 

lw 

ARG3,gc_mords_copied(ATEMP) 

;  get  GC  work  estimate 

slli 

ARG3.ARG3.1 

;  tag  the  value  for  PRIITF 

lw 

ARG4 ,  tot  al_allo  c at  ion  (  ATEMP  ) 

;  get  total  amt  allocated 

slli 

ARG4 , ARG4 , 1 

;  tag  the  value  for  PRIITF 

lw 

ARCS,  total_allocs(  ATEMP) 

;  get  total  calls  to  alloc 

slli 

ARG5 , ARG5 , 1 

;  tag  the  value  for  PRIITF 

Do 

call  to  printf 

lw 

ATEMP,  3 (ARGO) 

;  Jump  to  printf 

jalr 

ATEMP 

nop 

addui 

SP.SP.28 

lw 

ARGS,24(SP) 

lw 

ARG4,20(SP) 

lw 

ARG3,16(SP) 

lw 

ARG2, 12 (SP) 

lw 

ARG1,8(SP) 

lw 

ARG0,4(SP) 

lw 

RETADR.O(SP) 

jr 

RET ADR 

nop 

D.3  runtime/epilog.s 

The  contents  of  the  file  runtime/epilog.s: 


; ;  COMPILED  CODE  EIDS  HERE  . 

;;;  epilog. s  (in  comp/backend/runtime) 

l 

;  Epilog:  What  follows  makes-up  all  run-time  routines  used  by  the  microFX 
;  system.  Ve  let  the  DLX  simulator  do  any  necessary  linking,  and  if 

;  more  code  is  included  than  is  needed,  so  be  it.  See  macros. h 

;  for  register  definitions. 

t 

;  prolog. s  contains  initialization  code. 

» 

•include  "macros. h"  /*  registemame  macros,  etc  */ 
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startl_closure:  ;  Static  closure  ior  print!  routine 
. word  4 
.word  START_1 
. word  0 

printl_closure:  ;  Static  closure  ior  print!  routine 
. word  4 
.word  PRIITF 
. word  0 

stats_closure :  ;  Static  closure  lor  statistics  printing  routine 
. word  4 

.word  STATISTICS 
. word  0 

•include  "alloc. s“ 

•include  "Iraoes.s" 

•include  “print!. sM 
•include  "lib.s" 

;  .endprogram 

;  Does  nothing,  just  marks  the  end  ol  the  program  (and  hence  the 

;  beginning  ol  the  heap  at  initialization  time).  See  alloc. s 

;  to  see  how  this  is  used. 

I 

.endprogram: 


D.4  runtime/frames.s 


The  contents  of  the  file  runtime/frames.s: 


;  ;  frames  .a 
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.SAVE  —  save  registers  into  a  Iran* 
f  try: 

FP  contains  a  (tagged)  pointer  to  the  frame. 


; ;  On  exit : 

;  ATEMP  and  RET  ADR  trashed 

;;  r6 — r29  are  saved  into  frame  according  to  convention 

; ;  All  other  regs  are  preserved 

-SAVE: 

sb  lll(FP) ,r29 

sh  107 (FP) ,r28 

sb  103(FP),r27 

sb  99 (FP) ,r26 

sb  9S(FP).r2S 

sb  91 (FP) ,r24 

sb  87 (FP) ,r23 

sb  83(FP),r22 

sb  79(FP),r21 

sb  7S(FP).r20 

sb  71(FP) ,rl9 

sb  67(FP) ,rl8 

sb  63(FP).rl7 

sb  59(FP),rl8 

sb  66(FP) ,rl5 

sb  Sl(FP) ,rl4 

sb  47(FP).rl3 

sb  43(FP),rl2 

SB  39(FP) ,rll 

sb  3S(FP) ,rl0 

sb  31(FP) ,r9 

sb  27 (FP)  ,r8 

SB  23 (FP)  ,r7 

SB  19(FP),r8 

jr  RET ADR 

nop 
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D.5  runtime/ lib.  s 


-RESTORE  —  restore  regs  Iron  a  frame. 
On  entry: 

F?  points  to  the  frame 


-RESTORE: 

Is 

lu 

1b 

1b 

1b 

1b 

1b 

1b 

1b 

1b 

lB 

1b 

1b 

1b 

1b 

lB 

lB 

1b 

lB 

lB 

lB 

lB 

1b 

1b 

jr 

nop 


On  exit: 

rS — r29  are  restored  from  frame 
ATEMP  and  RET ADR  may  be  trashed 


r29, lll(FP) 

r28,107(FP) 

r27, 103(FP) 

r28,99(FP) 

r25,9S(FP) 

r24.91(FP) 

r23,87(FP) 

r22,83(FP) 

r21 ,79(FP) 

r20,7S(FP) 

rl9,71(FP) 

rl8,87(FP) 

rl7,63(FP) 

rl6,S9(FP) 

rl6,56(FP) 

rl4,5i(FP) 

rl3,47(FP) 

rl2,43(FP) 

rll ,39(FP) 

rlO,35(FP) 

r9,31(FP) 

r8,27(FP) 

r7,23(FP) 

rfl, 19(FP) 

RET ADR 


D.5  runtime/lib.s 

The  contents  of  the  file  runtime/lib.s: 

»  >  micro- FX  assembly-language  libraries 

; ;  Print  (tagged)  character  in  ARGO 

;;  callable  from  micro-FX  [has  type  (->  (char)  unit)] 

PUTCHAR: 

Is  RETADR, ll(FP) 

sub  VAL,  VAL,  VAL  ;  Return  value  zero 

j  -TPUTCHAR 

nop 
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; ;  .PUTCHAR  —  put  a  character  using  dlx  system  call 
; ;  On  entry : 

; ;  ATEMP  is  (untagged)  character  to  print 
; ;  On  exit : 

; ;  Stack  used  but  SP  preserved 

; ;  A TEMP  trashed 

putchax-X  ormat  jtring : 

.  asciiz  "Y,c“ 

.align  2 
put  char  jf  ormat : 

.  word  put  char _f  ormat_str  ing 

.space  4 

.TPUTCHAR:  ;;  Print  (tagged)  character  in  ATEMP. 

srai  ATEMP, ATEMP, 1  ;  untag  the  char 

JPUTCHAR :  ;;  Print  (untagged)  character  in  ATEMP. 


SS 

O(SP),  rl4  ; 

Save  old  value  of  rl4 

subui 

SP,  SP,  4 

lhi 

rl4,  (putchar_f ormat»16)  ; 

Pointer  to  args  in  rl4 

ori 

rl4,  rl4,  (putchar_XormatkOxXXXX) 

ss 

4(rl4) ,  ATEMP 

trap 

nop 

6  ; 

Call  print  built-in 

addui 

SP,  SP.  4 

Is 

rl4,  O(SP)  ; 

restore  rl4 

jr 

nop 

RET ADR  ; 

Return  to  caller 

; ;  .SYM2STRIIG  —  implements  low-level  part  oX  sym->string 
; ;  On  entry : 

; ;  ATEMP  points  to  uFX  symbol 
•  I 

; ;  On  exit : 

; ;  Stack  used  but  SP  preserved 
; ;  ATEMP  points  to  uFX  string 
JSYM2STRIIG: 


as 

0(SP) , ARGO 

;  Xree-up  some  temps 

ss 

-4(SP) , ARG1 

;  / 

ss 

-8(SP),ARG2 

;  / 

ss 

-12(SP) , RETADR 

;  / 

subui 

SP,  SP,  18 

or 

ARG2,  ATEMP,  ZERO 

;  Save  pointer  to  symbol  text 

subi 

ARG1 ,  ZERO,  1 

;  Initialize  length  counter 

: 

lbu 

ARGO,  0( ATEMP) 

;  Get  next  character  in  symbol 

addi 

ARG1 ,  ARG1,  1 

;  Inc  length  counter 

addui 

ATEMP,  ATEMP,  1 

;  Increment  symbol  pointer 

bnez 

nop 

ARGO,  lan .loop 

;  axt  char  is  not  ’\0’,  loop  again 
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slli 

ATEMP.  ARG1 ,  1  ; 

Tag  length  of  string  (D-slot ! ) 

jal 

-ALLOC  ; 

Allocate  vector  for  string 

nop 

or 

ARG1,  ATEMP,  ZERO  ; 

Save  pointer  returned  by  allocation 

fill-loop: 

lbu 

ARGO,  0(ARG2) 

Get  next  character  in  symbol 

addui 

ARG2,  ARG2.  1 

Increment  pointer  into  symbol 

slli 

ARGO,  ARGO,  1 

Tag  the  character 

beqz 

ARGO,  filljdone 

If  the  character  is  ’\0’,  quit  loop 

nop 

SB 

3(ARG1) ,  ARGO 

Store  character  in  heap  vector 

addui 

ARG1 ,  ARG1 ,  4 

Increment  pointer  into  heap  vector 

j 

fill-loop 

repeat 

nop 

fill-done: 

addui 

SP,  SP,  18 

1b 

RETADR,-12(SP) 

reload  the  temp  registers 

lB 

ARG2.-8CSP) 

/ 

lB 

ARG1 ,-4(SP) 

/ 

lB 

ARGO.O(SP) 

/ 

jr 

RET ADR 

and  return. 

nop 

D.6  runtime/ macros,  h 

The  contents  of  the  file  runtime/macros. h: 


/* 


macros. h:  macros  lor  easing  tbs  writing  of  prolog  and  spilog. 
do  /lib/cpp  -P  prolog. s  >  prolog. cods 
/lib/cpp  -P  spilog. s  >  spilog. code 
to  use  (dons  in  the  Makefile). 

*/ 

♦define  ZERO  rO 

♦define  VAL  rl 

♦define  EIV  r2 

♦define  FP  r3 

♦define  SP  r4 

♦define  HP  r5 

♦define  ARGO  r6 

♦define  ARG1  r7 

♦define  ARG2  r8 

♦define  ARG3  r9 

♦define  ARG4  rlO 

♦define  ARGS  rli 

♦define  ARG6  rl2 

♦define  ARG7  rl3 

♦define  ARG8  r!4 
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•define  ATEMP  r30 
•define  RET ADR  r31 

•define  FramaS iza  28  /*  (untagged)  #  words  in  a  frame.  */ 

#def iae  TOTALNEMSZZE  32768 


D.7  runtime/ print  f.s 

The  contents  of  the  file  mntime/printf.s: 


;;  priatf.s  (in  comp/backend/runtime) 


PRIITF: 


PRIHTF  —  A  primative  print! 

On  entry: 

ARG1  points  to  a  DLZ  string  (uFX  _symbol_)  with  grammar  7.x 


where  z  is: 

x  ::=  7. 

d 

b 

c 

s 

F 


pxx 

lx 


a  *y.>  sign 
(decimal)  integer 
boolean 
char 

string  (null-terminated) 
function 

pairs  (where  x  is  recursive  format) 
lists  (thus  a  list  of  lists  of  ints  is 
printed  by  Xlld) 


rx  refs 

vx  vectors 

ARG2 — ARG8  are  rest  of  print!  arguments  (up  to  6) 


On  exit: 

Uses  regular  uFX  calling  conventions,  ie,  almost  nothing  saved. 
Returns  the-unit. 


nop 

print!  -loop: 


lb 

VAL.O(ARGl) 

beqz 

VAL, end-print  •' 

nop 

seqi 

r29,VAL,0x26 

beqz 

r29 ,no_escape 

nop 

; ;  got 

a  7.,  see  shat 

addui 

ARG1 , ARG1 , 1 

lbu 

VAL.O(ARGl) 

beqz 

VAL.end-printf 

nop 

'V 
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seqi 

r29, VAL, 0x62 

» 

•b' 

bnez 

r29 , bool_out 

nop 

seqi 

r29, VAL. 0x63 

; 

’c’ 

bnez 

r  29 ,  char  .out 

nop 

seqi 

r29, VAL, 0x64 

i 

*d* 

bnez 

r29 ,  dec_out 

nop 

seqi 

r29, VAL, 0x70 

i 

•p< 

bnez 

r29,pair_out 

nop 

seqi 

r29,VAL,0x6c 

» 

*1* 

bnez 

r29,listjout 

nop 

seqi 

r29, VAL, 0x76 

» 

’v’ 

bnez 

r29,vec_0Ut 

nop 

seqi 

r29, VAL, 0x72 

9 

*r* 

bnez 

r29,ref jout 

nop 

seqi 

r29, VAL, 0x73 

9 

’s' 

bnez 

r29 ,  symjout 

nop 

;;  Otherwise,  just  print  the  escaped  character 
no.escape: 

jal  .PUTCHAR  ;  Print  the  character 

or  ATEMP,  V1L,  ZERO 

j  printf_loop 

addui  AR61 , ARG1 , 1 

end_printf  : 

Iw  RET ADR,  11 (FP) 

jr  RET ADR 

or  VAL,  ZERO,  ZERO 

shiften: 

or  ARG2 , ZERO , ARG3 

or  ARG3 , ZERO , ARG4 

or  ARG4 , ZERO , ARG5 

or  ARG6 , ZERO , ARG6 

or  ARG6 , ZERO , ARG7 

jr  RETADR 

or  ARG7 , ZERO , ARG8 
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; ;  To  print  a  char,  untag  it  and  use  _PUTCHAR 


char_out : 


dec.out : 


jal 

shiftem  ;  Shift  arguments  down 

srai 

ATEMP , ARG2 , 1  ;  Untag  char 

to  be  printed  (in  D-slot!) 

jal 

nop 

.PUTCHAR 

j 

printf .loop 

addui 

ARG1,  ARG1,  1 

;;  Use 

DLX’s  printf  with  '/.d  format 

lhi 

r  14,  (dec-format )» 18 

ori 

rl4,rl4,  (dec_forma*- 'tOxffff 

;  Load-up  the  '/.d  format 

srai 

VAL.ARG2, 1 

;  Untag  int  2B  printed 

sw 

4(rl4) ,VAL 

trap 

nop 

5 

jal 

nop 

shiftem 

;  shift  the  args  around. 

i 

printl_loop 

addui 

ARG1.ARG1.1 

dec_f ormat-string : 

.  asciiz  M'/.d" 


.align  2 
dec_f ormat : 

.  word  dec  .format  -string 

.space  4  ;  Save  space  lor  number  to  print 


; ;  Use  .PUTCHAR  to  print  a  t  then  a  T  or  F 
bool_out : 


jal 

_PUTCHAR 

;  Print 

ori 

ATEMP,  ZERO,  0x23 

;  / 

sne 

VAL.  ARG2,  ZERO 

ori 

1TEMP,  ZERO,  14 

all 

ATEMP,  ATEMP,  VAL 

addi 

ATEMP,  ATEMP,  56 

;  ATEMP  =  (VAL  ? 

jal 

.PUTCHAR 

nop 

jal 

shiftem 

nop 

j 

printf_loop 

addui 

ARG1 , ARG1 , 1 
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; ;  Use 

DLX  print!  here. 

sym_out : 

lhi 

rl4,  (string!ormat)»16 

ori 

rl4,rl4,  (string!oriBat)*Oxfffl 

sv 

4(rl4) ,  ARG2 

trap 

5 

nop 

jal 

shiftem  ;  shift  the  args  around. 

nop 

j 

print!_loop 

addui 

ARG1 , ARG1 , 1 

string.!  ormat_string : 

.asciiz 

"‘/.s'* 

.align 

2 

string!ormat : 

.word 

string.!  onaatjtring 

.apace 

4 
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build_lormat  —  build  format  for  recursive  call  to  printf 
On  entry: 

ARG1  points  to  first  character  of  the  old  format 
(excluding  '/,  sign) .  This  char  is  assumed  to  be  one  of 
the  compound  types  (1,  v,  p,  r) . 

On  exit: 

ATEMP  points  to  new  format  (allocated  on  stack) . 

ARG1  points  to  last  character  of  old  format 
rl4,rl5,rl8,rl7,rl8  trashed 


build_f  ormat : 


;  first 

calculate  length  of  nee  format  string  (minus  the  '/.  char) 

or 

rl4,  ARG1,  ZERO 

ori 

A TEMP,  ZERO,  0 

ori 

r!8,  ZERO,  0 

bf  -deeper : 

addi 

r!8,  r!8,  1 

;  Counts  nested  p’s 

bf  _len_loop : 

addui 

ri4,  rl4,  1 

lbu 

rlS,  0(rl4) 

addi 

ATEMP,  ATEMP,  1 

sequi 

rlfl,  rlS,  0x70 

;  ’p* 

bnez 

rl6,  bf .deeper 

sequi 

rl6,  rlE,  0x6c 

;  *1* 

bnez 

rl6,  bf_len_loop 

sequi 

rl7 ,  rlS,  0x72 

:  ’r* 

bnez 

rl7,  bfJLen-loop 

sequi 

rlfl.  rlS,  0x76 

.  >v» 

bnez 

rlfl,  bfJLen_loop 

nop 

subi 

rl8,  rl8,  1 

bnez 

rl8,  bf_len_loop 

nop 

bf _len_done : 

;  length  in  ATEMP 

;  Von  allocate  room  on  stack 

for  the  new  format  string  and  the  length 

;  of  the  string 

addi 

rl4,  ATEMP,  8 

;  Include  room  for  '7,'  k  a  length 

andi 

rl4,  rl4,  Oxfffc 

;  Align  length  to  word  boundary 

snbu 

SP,  SP,  rl4 

sv 

4(SP) ,  rl4 

;  Save  length  to  make  popping  easy 

;  Create  new  format  string  by  appending  a  ’  to  thing  passed  in 

addui 

rl4,  SP,  8 

;  Ptr  to  base  of  new  string 

ori 

rl5,  ZERO,  0x25 

sb 

0(rl4) ,  rl6 

;  Store  a 

bf-cpjLoop: 

addui 

ARG1 ,  ARG1,  1 

lbu 

rlS,  0(ARG1) 

addui 

rl4,  rl4,  1 

subi 

ATEMP,  ATEMP,  1 

sb 

0(rl4) ,  rl5 

bnez 

ATEMP,  bf-cp_loop 

nop 

bf  .done : 

addui 

rl4,  rl4,  1 

;  Terminate  format  string 

sb 

0(rl4) ,  ZERO 

jr 

RET ADR 

addui 

ATEMP,  SP,  8 

;  Return  pointer  to  nee  format  string 
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-pf-Xecurse : 

j  PRIITF 

as  il(FP) ,  RETADR 


; ;  Call  PRIITF  recursively  to  print  the  thing  pointed  to 
pair_out : 


lhi 

r!4,  (pair_hdr)»16 

l 

Print  "(pair  " 

ori 

trap 

nop 

rl4,rl4,(pairJidr)ft0xffff 

5 

; ;  Set 
jal 

up  stack-frame  for  recursive  call 

JS  ALLOC 

ori 

ATEMP,  ZERO,  (FrameSize*2) 

sw 

or 

3(ATEMP) ,  FP 

FP, ZERO, ATEMP 

;  Old  static  chain 

addi 

ATEMP,  SP,  (FrameSize+l)*4  ;  Old  SP 

as  7(FP) ,  ATEMP 

; ;  Print  thing  on  left 

;  / 

jal 

build_f  ormat 

1 

Returns  ptr  to  nee  string  in  ATEMP 

nop 

» 

ft  ARG1  pting  2  1st  chr  in  old  format 

or 

r29,  ZERO,  ATEMP 

> 

Stash  this  away  for  a  second 

jal 

nop 

.SAVE 

1 

Save  reg's  during  recursive  call 

or 

ARG1,  ZERO,  r29 

• 

Save  nev  format  string 

lw 

ARG2,3(ARG2) 

* 

Pass  item  to  print  in  ARG2 

jal 

nop 

_pf_recursa 

» 

Recursive  call  to  printf 

jal 

ori 

J>UTCHAR 

ATEMP,  ZERO,  0x20 

» 

Put  space  between  items 

jal 

nop 

;;  low 

JIESTORE 

do  right  hand  thing 

* 

Get  back  our  old  registers 

jal 

buil<Llormat 

» 

Returns  ptr  to  new  string  in  ATEMP 

nop 

* 

ft  ARG1  pting  2  1st  chr  in  old  format 

or 

r29,  ZERO,  ATEMP 

f 

Stash  this  away  for  a  second 

jal 

nop 

.SAVE 

A 

Save  reg's  during  recursive  call 

or 

ARG1,  ZERO ,r 29 

1 

Save  new  format  string 

la 

ARG2,7(ARG2) 

» 

Pass  item  to  print  in  ARG2 

nop 

_pf_recurse 

f 

Call  PRIITF  recursively 

jal 

ori 

jal 

nop 

J>OTCHAR 

ATEMP,  ZERO,  0x29 
JIESTORE 

1 

Put  closing  ’)’ 
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; ;  Finish  up 


Is 

SP,7(FP) 

;  Get  rid  of  activation  frame 

Is 

FP,3(FP) 

;  / 

jal 

shift em 

;  Shift  args  down 

nop 

j 

printl_loop 

addui 

ARG1,  ARG1,  1 

pair  _hdr_string : 

. asciiz 

"(pair  " 

.align 

2 

pair  Jidr : 

.  sord 

pair_hdr_string 

.space 

4 

;;  Call 

PRIITF  recursively  to  print  the  list  items. 

list_out : 

jal 

JPGTCHAR 

;  Put  a  *(* 

ori 

ATEMP,  ZERO,  0x28 

;;  Set 

up  stack-frame  for 

recursive  call 

jal 

_S ALLOC 

ori 

ATEMP,  ZERO,  (FrameSizee2) 

ss 

3(ATEMP) ,  FP 

;  Old  static  chain 

or 

FP, ZERO, ATEMP 

addi 

ATEMP,  SP,  (FrameSize+l)*4  ;  Old  SP 

ss 

7(FP) ,  ATEMP 

;  / 

jal 

buildjCormat 

;  Returns  ptr  to  nes  string  in  ATEMP 

nop 

;  *  ARG1  pting  2  1st  chr  in  old  format 

or 

r29, ZERO, ATEMP 

;  Save  ptr  to  nes  string  in  stack  slot 

beqz 

ARG2,list_done 

;  If  list  is  empty,  skip  loop 

nop 

j 

list_noapace 

;  skip  space  in  front  of  first  item 

nop 
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liat_loop: 


J>UTCHAR 

;  Print  a  space  in  front  ol  item 

ori 

ATEMP,  ZERO.  0x20 

;  (in  D-slot ! ) 

list_nospace: 

jal 

.SAVE 

nop 

or 

ARGl,ZER0,r29 

;  Pass  format  string  in  ARG1 

Is 

ARG2.3URG2) 

;  Pass  item  to  print  in  ARG2 

jal 

_pf .recurs a 

;  Call  PRISTF  recursively 

nop 

jal 

.RESTORE 

nop 

Is 

ARG2,7(ARG2) 

bnaz 

ARG2.liatJ.oop 

;  do  again  if  more  items  in  list 

nop 

list_dona: 

Is 

SP,7(FP) 

;  Gat  rid  of  activation  frame. 

Is 

FP,3(FP) 

;  / 

jal 

JPUTCHAR 

;  Print  closing  ’)’ 

ori 

ATEMP,  ZERO,  0x29 

jal 

shift aa 

;  Shift  args  down 

nop 

j 

printl  Joop 

addui 

ARG1 ,  ARG1 .  1 

; ;  Call 

PRI1TF  recursively  to  print  tba  vac  iteas. 

vacant : 

jal 

J>OTCHAR 

;  Put  a  ’#’ 

ori 

ATEMP.  ZERO,  0x23 

jal 

J>UTCHAR 

;  Put  a  ’(’ 

ori 

ATEMP,  ZERO,  0x28 

;;  Sat 

np  stack-frame  lor  racuraiva  call 

jal 

-S  ALLOC 

ori 

ATEMP,  ZERO,  (FrameSize*2) 

as 

3(ATEMP) ,  FP 

;  Old  static  chain 

or 

FP, ZERO, ATEMP 

addi 

ATEMP,  SP,  (FrameSize+i)*4  ;  Old  SP 

as 

7(FP) ,  ATEMP 

;  / 

jal 

build^ormat 

;  Returns  ptr  to  nas  string  in  ATEMP 

nop 

;  A  ARG1  pting  2  1st  chr  in  old  format 

or 

r28, ZERO .ATEMP 

;  Sava  nas  format  string 

Is 

r29,  -1(ARG2) 

;  Gat  length  of  vector 

baqz 

r29,  vec_done 

;  If  vac  is  empty,  skip  loop 

nop 

j 

vac_noapaca 

;  skip  space  in  front  of  first  item 

nop 
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vecJoop: 


jal 

-PUTCHAR 

;  Print  a  space  in  front  of  item 

ori 

ATEMP,  ZERO,  0x20 

;  (in  D-slot ! ) 

vec_nospace: 

jal 

.SAVE 

nop 

or 

ARG1 .ZERO ,r28 

;  Pass  format  string  in  ARG1 

la 

ARG2,3(ARG2) 

;  Pass  item  to  print  in  ARG2 

jal 

_pf_recurse 

;  Call  PRIITF  recursively 

nop 

vec_return: 

jal 

-RESTORE 

nop 

addui 

ARG2.ARG2.4 

;  Advance  to  next  item  in  vec 

snbi 

r29,r29,2 

;  do  a  .tagged,  subtract  of  1 

bnez 

r29.vecJ.oop 

;  do  again  if  more  items  in  vec 

nop 

vac^done: 

la 

SP.T(FP) 

;  Get  rid  of  activation  frame. 

la 

FP,3(FP) 

;  / 

jal 

-PUTCHAR 

;  Print  closing  * ) * 

ori 

ATEMP,  ZERO,  0x29 

jal 

shiftea 

;  Shift  args  down 

nop 

j 

print!  Joop 

addui 

ARG1 ,  ARG1 ,  1 

;;  Call 

PRIITF  recursively  to  print  the  thing  pointed  to 

ref _out : 

lhi 

rl4, (ref Jhdr)»16  ;  Print  "(ref  •• 

ori 

rl4,rl4,  (ref-hdr)fcOxffff 

trap 

5 

nop 

i  *  Set 

up  stack-frame  for  recursive  call 

jal 

_S ALLOC 

ori 

ATEMP,  ZERO,  (FrameSize*2) 

or 

FP, ZERO, ATEMP 

sa 

3(ATEMP),  FP  ;  Old  static  chain 

addi 

ATEMP,  SP,  (FrameSize+l)*4  ;  Old  SP 

sa 

7(FP),  ATEMP  ;  / 

jal 

buildJormat  ;  Returns  ptr  to  nea  string 

in  ATEMP 

nop 

;  A  ARG1  pting  2  1st  chr  in 

old  format 

or 

r29,  ATEMP,  ZERO  ;  Save  nea  format  string 

-SAVE 

ARG1 .ZERO ,r29 

ARG2,3(ARG2)  ;  Pass  it e>  to  print  in  ARG2 

-Pf-^curse  ;  Call  PRIITF  recursively 


jal 

or 

Is 

jal 

nop 
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1b  SP,7(FP)  ;  Get  rid  of  activation  frame, 

lw  FP ,3(FP)  ;  / 

jal  .RESTORE 

nop 

jal  .PUTCHAR  ;  Put  closing  ’)’ 

ori  ATEJtP,  ZERO,  0x29 

jal  shiftam  ;  Shift  args  down 

nop 

j  printf_loop 

addui  ARG1 ,  ARG1,  1 

ref  _hdr  .string : 

. asciiz  "(ref  " 

.align  2 

r ef _hdr : 

.word  ref  Jxdrjtring 

.align  2 


D.8  runtime/prolog.s 

The  contents  of  the  file  runtime/prolog.s: 


;;  prolog. s  (in  comp/backend/runtime) 

prolog. s:  microF*  program  prolog.  This  gets  prefixed  to  every  compiled  file 


•include  "Macros. h"  /*  registername  macros,  etc  */ 

;;  Execution  starts  right  here! 

.global  PRIITF 
.global  STATISTICS 

; *  is  needed  due  to  dlxsia  bug  :-( 
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program.  1 : 


; ;  zaro  rags  so  that  gc  stays  happy  (all 

rag's  have  taggad  values) 

or 

rl, ZERO, ZERO 

or 

r2, ZERO, ZERO 

or 

r3, ZERO, ZERO 

or 

r4, ZERO, ZERO 

or 

rS, ZERO, ZERO 

or 

rfl, ZERO, ZERO 

or 

r7, ZERO, ZERO 

or 

r8, ZERO, ZERO 

or 

rd, ZERO, ZERO 

or 

rlO, ZERO, ZERO 

or 

r 11. ZERO. ZERO 

or 

r 12, ZERO, ZERO 

or 

rl3, ZERO, ZERO 

or 

rl4, ZERO, ZERO 

or 

r 16, ZERO, ZERO 

or 

r 16, ZERO, ZERO 

or 

rl7, ZERO. ZERO 

or 

rl8, ZERO, ZERO 

or 

r 19, ZERO, ZERO 

or 

r20, ZERO, ZERO 

or 

r21, ZERO, ZERO 

or 

r22, ZERO. ZERO 

or 

r23, ZERO, ZERO 

or 

r24, ZERO, ZERO 

or 

r25. ZERO, ZERO 

or 

r20. ZERO, ZERO 

or 

r27, ZERO, ZERO 

or 

r28, ZERO, ZERO 

or 

r29, ZERO, ZERO 

or 

r 30, ZERO, ZERO 

jal 

_init_runtiae  ; 

Init  runtime  ays 

nop 

;;  Sat 

-up  an  initial  frame  to  rstum  through 

ori 

A TEMP ,  ZERO,  FrameSize 

jal 

-ALLOC 

nop 

or 

FP,  ATEMP,  ZERO  ; 

FP  points  to  frame 

aw 

3(FP) .ZERO 

IS 

7(FP) ,SP 

Ihi 

ATEMP,  (print_ras)»  16  ; 

place  to  return  to 

ori 

ATEMP, ATEMP, (print  _res)*Oxffff  ; 

/ 

sw 

ll(FP), ATEMP 

/ 

aw 

15(FP) .ZERO 

D  nFX/DLX  RUN-TIME  IMPLEMENTATION _ D.8  runtime/prolog.s 


;;  jump  to  START-1  through,  statically-created  closure. 


lhi 

ARGO,  (startl_closure+l)»16  ; 

Get  closure  to  print! 

ori 

ARGO,  ARGO,  (startl_closure+l)AOxif!!  ;  / 

lw 

ATEMP,  3 (ARGO)  ; 

Jump  to  START-1 

jr 

ATEMP 

aop 

print_res : 

;;  Print  result  by  calling  print!.  Recall 

that  the  compiler 

; ; 

us  a  string  “RESULT-FORMAT"  which 

is  a  print!  !ormat 

;;  lor  the  type  o!  the  result.  (Reuses  activation  from  from 

; ;  above . ) 

lhi 

ATEMP,  (priat_stat)»16 

place  !or  print!  to  return  to 

ori 

ATEMP,  ATEMP,  (print_stat )  *0x11!!  ; 

/ 

sw 

ll(FP), ATEMP  ; 

/ 

lhi 

ARGO,  (print!_closure+l)»16  ; 

Get  closure  to  print! 

ori 

ARGO, ARGO, (print!_closure+l)AOx!!!i  ;  / 

lhi 

ARG1 ,  (RESULT_F0RMAT)»16 

put  the  format  string  in  ARG1 

ori 

ARG1 ,  ARG1 ,  (  RESULT-FORMAT)  AOx!!!! 

/ 

or 

ARG2 , ZERO , VAL  ; 

put  the  returned  val  in  ARG2 

Is 

ATEMP,  3 (ARGO)  ; 

Jump  to  print! 

jr 

ATEMP  I 

/ 

nop 

print-stat : 

; ;  Print  a  couple  ol  nee-lines 

ori 

ATEMP,  ZERO.  10 

jal 

-PUTCHAR 

nop 

ori 

ATEMP.  ZERO,  10 

jal 

-PUTCHAR 

nop 

;;  Cali 

STATISTICS  to  print  stat’s 

lhi 

ATEMP.  (-£XIT)»ie  ; 

place  !or  stats  to  return  to 

ori 

ATEMP, ATEMP,  (.EXIT) AOxlill  ; 

/ 

sw 

ll(FP), ATEMP  ; 

/ 

lhi 

ARGO,  (stats_closure+l)»16  ; 

Get  closure  to  stats  printing 

ori 

ARGO,  ARGO,  (stats_closure+l)AOxl!ff 

lw 

ATEMP,  3 (ARGO)  ; 

Jump  to  statistics 

jr 

ATEMP  ; 

/ 

nop 

-EIIT: 

trap 

0  ; 

"exit"  sys  call 

nop 

; ;  COMPILED  CODE  STARTS  HERE 
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